CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. LEMEDIT.
000030 AUTHOR. RALPH BACK.
000040 INSTALLATION. THE BOEING COMPANY  HOUSTON, TEXAS.
000050 REMARKS.        PROCEDURE
000060         READ THE GRUMMAN LEM TAPE AND REPORT 655M TYPE
000070         RECORDS.
000080         THE LEM VEHICLE NO. AND DATE ARE INPUT THROUGH A
000090         CONTROL CARD.
000100         THE SELECTED RECORDS ARE WRITTEN ON TAPE AND SYSOUT.
000110 ENVIRONMENT DIVISION.
000120 CONFIGURATION SECTION.
000130 SOURCE-COMPUTER. IBM-360.
000140 OBJECT-COMPUTER. IBM-360.
000150 INPUT-OUTPUT SECTION.
000160 FILE-CONTROL.
000170     SELECT  CONTROL-CARD-FILE   ASSIGN TO UT-S-CCARD.
000180     SELECT  SYSOUT-FILE         ASSIGN TO UT-S-PRINT.
000190     SELECT  INPUT-FILE          ASSIGN TO UT-S-INPUT.
000200     SELECT  OUTPUT-FILE         ASSIGN TO UT-S-OUTPUT.
000210 DATA DIVISION.
000220 FILE SECTION.
000230 FD  CONTROL-CARD-FILE
000240         LABEL RECORD OMITTED
000250         RECORDING MODE F
000260         DATA RECORD CARD-FORMAT.
000270 01  CARD-FORMAT.
000280     02  DATE    PICTURE X(8).
000290     02  FILLER  PICTURE X.
000300     02  VEHICLE PICTURE X(10).
000310     02  FILLER  PICTURE X(61).
000320 FD  SYSOUT-FILE
000330         LABEL RECORD OMITTED
000340         REPORT LEM-655M.
000350 FD  INPUT-FILE
000360         RECORDING MODE F
000370         LABEL RECORD OMITTED
000380         BLOCK 6 RECORDS
000390         DATA RECORD INPUT-FORMAT.
000400 01  INPUT-FORMAT.
000410     02  FILLER          PICTURE X(13).
000420     02  RECORD-TYPE     PICTURE X(4).
000430     02  FILLER          PICTURE X(66).
000440     02  FROM-CONNECTOR.
000450         03  FROM-PIN    PICTURE X(10).
000460         03  FROM-GUAGE  PICTURE XX.
000470     02  FILLER          PICTURE X(6).
000480     02  TO-CONNECTOR.
000490         03  TO-PIN      PICTURE X(10).
000500         03  TO-GUAGE    PICTURE XX.
000510     02  FILLER          PICTURE X(12).
000520     02  DRAWING-NO      PICTURE X(12).
000530     02  NOMENCLATURE    PICTURE X(18).
000540     02  FILLER          PICTURE X(55).
000550     02  WIRE-NO         PICTURE X(14).
000560     02  FILLER          PICTURE X(22).
000570 FD  OUTPUT-FILE
000580         RECORDING MODE F
000590         LABEL RECORD OMITTED
000600         BLOCK 50 RECORDS
000610         DATA RECORD LEM-RECORD.
000620 01  LEM-RECORD.
000630     02  FROM-ITEM       PICTURE X(12).
000640     02  TO-ITEM         PICTURE X(12).
000650     02  DWG-NO          PICTURE X(12).
000660     02  NOMEN           PICTURE X(18).
000670     02  WIRE            PICTURE X(14).
000680 WORKING-STORAGE SECTION.
000690 77  NRDS                PICTURE S9(8) COMPUTATIONAL.
000700 77  NWRS                PICTURE S9(8) COMPUTATIONAL.
000710 77  WS-DATE             PICTURE X(8).
000720 77  WS-VEHICLE          PICTURE X(10).
000730 REPORT SECTION.
000740 RD  LEM-655M
000750         PAGE LIMIT IS 60 LINES
000760         HEADING 1
000770         FIRST DETAIL 5
000780         LAST DETAIL 60.
000790 01  TYPE PAGE   HEADING LINE 1.
000800     02  COLUMN  30  PICTURE X(7) VALUE 'VEHICLE'.
000810     02  COLUMN  38  PICTURE X(10) SOURCE WS-VEHICLE.
000820     02  COLUMN  90  PICTURE X(4) VALUE 'DATE'.
000830     02  COLUMN  95  PICTURE X(8) SOURCE WS-DATE.
000840     02  LINE PLUS 2 COLUMN 10 PICTURE X(4) VALUE 'FROM'.
000850     02  COLUMN 22 PICTURE XX VALUE 'GA'.
000860     02  COLUMN 28 PICTURE XX VALUE 'TO'.
000870     02  COLUMN 40 PICTURE XX VALUE 'GA'.
000880     02  COLUMN 47 PICTURE X(10) VALUE 'DRAWING-NO'.
000890     02  COLUMN 65 PICTURE X(12) VALUE 'NOMENCLATURE'.
000900     02  COLUMN 87 PICTURE X(7) VALUE 'WIRE-NO'.
000910 01  DETAIL-RECORD TYPE DETAIL LINE PLUS 1.
000920     02  COLUMN  10  PICTURE X(10) SOURCE FROM-PIN.
000930     02  COLUMN  22  PICTURE XX    SOURCE FROM-GUAGE.
000940     02  COLUMN  28  PICTURE X(10) SOURCE TO-PIN.
000950     02  COLUMN  40  PICTURE XX    SOURCE TO-GUAGE.
000960     02  COLUMN  47  PICTURE X(12) SOURCE DRAWING-NO.
000970     02  COLUMN  65  PICTURE X(18) SOURCE NOMENCLATURE.
000980     02  COLUMN  87  PICTURE X(14) SOURCE WIRE-NO.
000990 01  TYPE REPORT FOOTING LINE NEXT PAGE.
001000     02  COLUMN  1   PICTURE X(20) VALUE 'EXEC STATISTCAL DATA'.
001010     02  LINE PLUS 1 COLUMN 1 PICTURE X(6)  VALUE 'RCDIN='.
001020     02  COLUMN  10  PICTURE Z(8) SOURCE NRDS.
001030     02  LINE PLUS 1 COLUMN 1 PICTURE X(7)  VALUE 'RCDOUT='.
001040     02  COLUMN  10  PICTURE Z(8) SOURCE NWRS.
001050 PROCEDURE DIVISION.
001060     MOVE 0 TO NRDS, NWRS.
001070     OPEN INPUT CONTROL-CARD-FILE.
001080     READ CONTROL-CARD-FILE  AT END CLOSE CONTROL-CARD-FILE,
001090         DISPLAY 'CONTROL CARD MISSING   JOB ENDED',
001100         STOP RUN.
001110     MOVE DATE TO WS-DATE.
001120     MOVE VEHICLE TO WS-VEHICLE.
001130     CLOSE CONTROL-CARD-FILE.
001140     OPEN INPUT INPUT-FILE.
001150     OPEN OUTPUT SYSOUT-FILE.
001160     OPEN OUTPUT OUTPUT-FILE.
001170     INITIATE LEM-655M.
001180 READ-GRUMMAN-TAPE.
001190     READ INPUT-FILE AT END GO TO JOBEND.
001200     COMPUTE NRDS = NRDS + 1.
001210     IF RECORD-TYPE = '655M' NEXT SENTENCE
001220         ELSE
001230     GO TO READ-GRUMMAN-TAPE.
001240     MOVE FROM-CONNECTOR TO FROM-ITEM.
001250     MOVE TO-CONNECTOR TO TO-ITEM.
001260     MOVE DRAWING-NO TO DWG-NO.
001270     MOVE NOMENCLATURE TO NOMEN.
001280     MOVE WIRE-NO TO WIRE.
001290     WRITE LEM-RECORD.
001300     COMPUTE NWRS = NWRS + 1.
001310     GO TO READ-GRUMMAN-TAPE.
001320 JOBEND.
001330     TERMINATE LEM-655M.
001340     CLOSE OUTPUT-FILE.
001350     CLOSE INPUT-FILE.
001360     CLOSE SYSOUT-FILE.
001370     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.   'BEDUPDT'.
000030 AUTHOR.          LENN BOMAR.
000040 INSTALLATION.    HOUSTON.
000050 DATE-WRITTEN.    MARCH 5, 1968.
000060 DATE-COMPILED. JUN 17,1969
000070 REMARKS. COMBINES N/R, AC  AND GRUMMAN WIRELISTS, ALSO
000080          GENERATES HARNESS WIRELIST REPORT.
000090 ENVIRONMENT DIVISION.
000100 CONFIGURATION SECTION.
000110 SOURCE-COMPUTER. IBM-360.
000120 OBJECT-COMPUTER. IBM-360.
000130 INPUT-OUTPUT SECTION.
000140 FILE-CONTROL.
000150     SELECT NA-TAPE   ASSIGN TO UT-S-NATPE.
000160     SELECT GRUM-TAPE ASSIGN TO UT-S-GRTPE.
000170     SELECT GSE-TAPE  ASSIGN TO UT-S-GSETPE.
000180     SELECT WIREMERG ASSIGN TO UT-S-WRMRG.
000190     SELECT WIRE-SORT ASSIGN UT-S-SD1.
000200     SELECT WIRE-RPT  ASSIGN TO UT-S-WIRLST.
000210     SELECT DATA-CRDS ASSIGN TO UT-S-DATAIN.
000220     SELECT T-DISK ASSIGN TO UT-S-SORTOUT.
000230     SELECT ERROR-FILE   ASSIGN UT-S-SYSERRS.
000240 DATA DIVISION.
000250 FILE SECTION.
000260 FD  ERROR-FILE
000270         RECORDING MODE F
000280         LABEL RECORD OMITTED
000290         DATA RECORD ERROR-RCD.
000300 01  ERROR-RCD.
000310     02  ERR-MSG     PICTURE X(20).
000320     02  ERR-RCD     PICTURE X(87).
000330 FD  DATA-CRDS
000340     LABEL RECORDS OMITTED
000350     RECORDING MODE IS F
000360     BLOCK CONTAINS 21 RECORDS
000370     RECORD CONTAINS 80 CHARACTERS
000380     DATA RECORDS ARE CARD-DATE IN-CARDS.
000390 01  CARD-DATE.
000400     02 DATER    PICTURE X(10).
000410     02 FILLER       PICTURE X(70).
000420 01  IN-CARDS.
000430     02  FILLER      PICTURE X.
000440     02  ACT         PICTURE X.
000450      02 FCONN.
000460       03 FCNTR      PICTURE X.
000470       03 FAREA      PICTURE X.
000480       03 FITEM      PICTURE X(6).
000490      02 FPIN        PICTURE X(4).
000500      02 TCONN.
000510       03 TCNTR      PICTURE X.
000520       03 TAREA      PICTURE X.
000530       03 TITEM      PICTURE X(6).
000540      02 TPIN        PICTURE X(4).
000550  02  AREA-S     PICTURE X(7).
000560     02  REMARK      PICTURE X(26).
000570     02  FBAY-NO     PICTURE X(3).
000580     02  TBAY-NO     PICTURE X(3).
000590     02  GSE-FROM-AH PICTURE X(4).
000600     02  GSE-TO-AH   PICTURE X(11).
000610 FD  NA-TAPE
000620     LABEL RECORDS OMITTED
000630     RECORDING MODE IS F
000640     BLOCK CONTAINS 20 RECORDS
000650     RECORD CONTAINS 87 CHARACTERS
000660     DATA RECORD IS NORTH-AMERICAN.
000670 01  NORTH-AMERICAN  PICTURE X(87).
000680 FD  GRUM-TAPE
000690     LABEL RECORDS OMITTED
000700     RECORDING MODE IS F
000710     RECORD CONTAINS 87 CHARACTERS
000720         BLOCK 20 RECORDS
000730     DATA RECORD IS GRUMMAN.
000740 01  GRUMMAN         PICTURE X(87).
000750 FD  GSE-TAPE
000760     LABEL RECORDS OMITTED
000770     BLOCK CONTAINS 20 RECORDS
000780     RECORD CONTAINS 87 CHARACTERS
000790     RECORDING MODE IS F
000800     DATA RECORD IS GSE.
000810 01  GSE             PICTURE X(87).
000820 FD  WIREMERG
000830     RECORDING MODE IS F
000840     BLOCK CONTAINS 10 RECORDS
000850     LABEL RECORDS OMITTED
000860     DATA RECORD IS MASTWIRE.
000870 01  MASTWIRE    PICTURE X(149).
000880 SD  WIRE-SORT
000890     RECORDING MODE IS F
000900     DATA RECORD IS SRT-WIRE.
000910 01  SRT-WIRE.
000920     02 CONN1.
000930        03 F-CONT    PICTURE X(01).
000940        03 F-AREA    PICTURE X(01).
000950        03 FROM-REF.
000960           04 F-TYPE PICTURE X(06).
000970           04 F-BAY  PICTURE X(3).
000980           04 FILLER PICTURE X.
000990        03 F-PIN     PICTURE X(04).
001000     02 CONN2.
001010        03 TO-CONT   PICTURE X(01).
001020        03 TO-AREA   PICTURE X(01).
001030        03 TO-REF.
001040           04 TO-TYPE PICTURE X(06).
001050           04 T-BAY  PICTURE X(3).
001060           04 FILLER PICTURE X.
001070        03 TO-PIN    PICTURE X(04).
001080     02  FROM-AREA-HARNESS   PICTURE X(11).
001090     02  FILLER              PICTURE X(4).
001100     02 ROMRKS.
001110        03 FILLER    PICTURE X(26).
001120        03 TO-AREA-HARNESS   PICTURE X(11).
001130        03 ACTION    PICTURE X(01).
001140        03 GSE-INDICATE      PICTURE X.
001150        03 DUP       PICTURE X.
001160     02  GSE-REMARKS REDEFINES ROMRKS.
001170         03  F1      PICTURE X(27).
001180         03  F2      PICTURE X(11).
001190         03  F3      PICTURE XX.
001200 FD  T-DISK
001210     LABEL RECORDS OMITTED
001220     RECORDING MODE IS F
001230     BLOCK CONTAINS 40 RECORDS
001240     RECORD CONTAINS 87 CHARACTERS
001250     DATA RECORD IS ACTDEL.
001260 01  ACTDEL          PICTURE X(87).
001270 FD  WIRE-RPT
001280     BLOCK CONTAINS 15 RECORDS
001290     LABEL RECORDS OMITTED
001300     RECORD CONTAINS 132 CHARACTERS
001310     RECORDING MODE IS F
001320     DATA RECORD IS LINER.
001330 01  LINER   PICTURE X(132).
001340 WORKING-STORAGE SECTION.
001350 77  QQ      PICTURE X(11) VALUE 'BEGINS HERE'.
001360 77  NERRS       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001370 77  NRADD       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001380 77  NRDEL       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001390 77  NRWR        PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001400 77  NRRD        PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001410 77  EOF-SW      PICTURE X VALUE '0'.
001420 77  HD  PICTURE 9 VALUE 1.
001430 77  WS-AREA  PICTURE X VALUE SPACE.
001440 77  LN-CNT   PICTURE 9(2) VALUE 0.
001450 77  MAX      PICTURE 9(2) VALUE 55.
001460 77  WS-CONT     PICTURE X(01) VALUE SPACE.
001470 01  HOLD-OUT.
001480     02  GSE-FROM-AREA-HARNESS   PICTURE X(11).
001490     02  FILLER  PICTURE X(4) VALUE SPACES.
001500     02  CONN1H      PICTURE X(16).
001510     02  CONN2H      PICTURE X(16).
001520     02  DIODE       PICTURE 9       VALUE ZERO.
001530     02  IMPED       PICTURE 9(3)    VALUE ZERO.
001540     02  AREAHH      PICTURE X(15).
001550     02  REMRKH.
001560         03  F4      PICTURE X(26).
001570         03  F5      PICTURE X(11).
001580         03  F6      PICTURE XX.
001590         03  FILLER  PICTURE X.
001600     02  FILLER      PICTURE X(42)   VALUE SPACE.
001610     02  DUP2        PICTURE X   VALUE SPACE.
001620 01  HOLD-ACTION.
001630     02 TRANS-FROM   PICTURE X(16).
001640     02 TRANS-TO     PICTURE X(16).
001650     02  REFDES.
001660         03  FR-AREAH    PICTURE X(11).
001670         03  FILLER      PICTURE X(4).
001680     02  REMRKS      PICTURE X(37).
001690     02 ACC          PICTURE X.
001700     02  GSE-RCD     PICTURE X.
001710     02  DUPH        PICTURE X.
001720 01  HOLD-SRT.
001730     02  FCONN.
001740      03 FCNTR       PICTURE X.
001750      03 FAREA       PICTURE X.
001760      03 FITEM       PICTURE X(6).
001770     02  FBAY-NO     PICTURE X(3).
001780     02  FILLER      PICTURE X VALUE SPACE.
001790     02  FPIN        PICTURE X(4).
001800     02  TCONN.
001810      03 TCNTR       PICTURE X.
001820      03 TAREA       PICTURE X.
001830      03 TITEM       PICTURE X(6).
001840     02  TBAY-NO     PICTURE X(3).
001850     02  FILLER      PICTURE X VALUE SPACE.
001860     02  TPIN        PICTURE X(4).
001870     02  AREA-S.
001880      03 AREAH       PICTURE X(7).
001890      03 GSE-FROM-AH PICTURE X(4).
001900     02  FILLER      PICTURE X(4) VALUE SPACES.
001910     02  REMARK      PICTURE X(26).
001920     02  GSE-TO-AH   PICTURE X(11).
001930     02  ACT         PICTURE X.
001940     02  GSE-FLAG    PICTURE X.
001950     02  FILLER      PICTURE X.
001960 01  DTLINE.
001970     02 FILLER   PICTURE X(02) VALUE SPACES.
001980     02 A-CODE   PICTURE X(12) VALUE SPACES.
001990     02 FILLER   PICTURE X(35) VALUE SPACES.
002000     02 DATE     PICTURE X(10) VALUE SPACES.
002010     02 FILLER   PICTURE X(31) VALUE SPACES.
002020     02 FILLER   PICTURE X(06) VALUE 'PAGE ('.
002030     02 PG-NO    PICTURE 9(04) VALUE 0.
002040     02 FILLER   PICTURE X(06) VALUE ')     '.
002050 01  RPT-NAME.
002060     02 FILLER   PICTURE X(46) VALUE SPACES.
002070     02 FILLER   PICTURE X(17) VALUE 'HARNESS WIRE LIST'.
002080     02 FILLER   PICTURE X(43) VALUE SPACES.
002090 01  AST-LINE.
002100     02 FILLER   PICTURE X(53) VALUE ALL '*'.
002110     02 FILLER   PICTURE X(53) VALUE ALL '*'.
002120 01  BLNK        PICTURE X(106) VALUE SPACES.
002130 01  HEAD1.
002140     02 FILLER       PICTURE X(09) VALUE SPACES.
002150     02 FILLER       PICTURE X(21) VALUE 'CONNECTOR DESIGNATORS'.
002160     02 FILLER       PICTURE X(76) VALUE SPACES.
002170 01  FR-TO.
002180     02 FILLER       PICTURE X(09) VALUE SPACES.
002190     02 FILLER       PICTURE X(04) VALUE 'FROM'.
002200     02 FILLER       PICTURE X(19) VALUE SPACES.
002210     02 FILLER       PICTURE X(02) VALUE 'TO'.
002220     02 FILLER       PICTURE X(72) VALUE SPACES.
002230 01  HEAD2.
002240     02 FILLER       PICTURE X(02) VALUE SPACES.
002250     02 FILLER       PICTURE X(09) VALUE 'CONNECTOR'.
002260     02 FILLER       PICTURE X(06) VALUE SPACES.
002270     02 FILLER       PICTURE X(03) VALUE 'PIN'.
002280     02 FILLER       PICTURE X(04) VALUE SPACES.
002290     02 FILLER       PICTURE X(09) VALUE 'CONNECTOR'.
002300     02 FILLER       PICTURE X(06) VALUE SPACES.
002310     02 FILLER       PICTURE X(03) VALUE 'PIN'.
002320     02 FILLER       PICTURE X(19) VALUE SPACES.
002330     02 FILLER   PICTURE X(07) VALUE 'REMARKS'.
002340     02 FILLER   PICTURE X(20) VALUE SPACES.
002350     02 DES-NET  PICTURE X(10) VALUE SPACES.
002360     02 FILLER   PICTURE X(06) VALUE SPACES.
002370 01  VEND-LINE.
002380     02 FILLER   PICTURE X(47) VALUE SPACES.
002390     02 VENDOR   PICTURE X(15) VALUE SPACES.
002400     02 FILLER  PICTURE X(44) VALUE SPACES.
002410 01  DATA-LINE.
002420     02 FILLER   PICTURE X(03) VALUE SPACES.
002430     02 WR-FR-REF PICTURE X(12) VALUE SPACES.
002440     02 FILLER    PICTURE X(03) VALUE SPACES.
002450     02 WR-FR-PIN  PICTURE X(04).
002460     02 RE-FR-PIN REDEFINES WR-FR-PIN  PICTURE 9(04).
002470     02 FILLER       PICTURE X(03) VALUE SPACES.
002480     02 WR-TO-REF    PICTURE X(12) VALUE SPACES.
002490     02 FILLER       PICTURE X(03) VALUE SPACES.
002500     02 WR-TO-PIN  PICTURE X(04).
002510     02 RE-TO-PIN REDEFINES WR-TO-PIN  PICTURE 9(04).
002520     02 FILLER       PICTURE X(03) VALUE SPACES.
002530     02 WR-RMKS      PICTURE X(40) VALUE SPACES.
002540     02 FILLER       PICTURE X(01) VALUE SPACES.
002550     02 WR-DES       PICTURE X(15) VALUE SPACES.
002560     02 FILLER       PICTURE X(03) VALUE SPACES.
002570 01  SEP.
002580     02 FILLER  PICTURE X(23) VALUE SPACES.
002590     02 FILLER  PICTURE X(01) VALUE '*'.
002600     02 FILLER  PICTURE X(21) VALUE SPACES.
002610     02 FILLER  PICTURE X(01) VALUE '*'.
002620     02 FILLER  PICTURE X(59) VALUE SPACES.
002630 PROCEDURE DIVISION.
002640     OPEN INPUT DATA-CRDS, OUTPUT ERROR-FILE.
002650     READ DATA-CRDS AT END
002660     GO TO END-UP.  MOVE DATER TO DATE.
002670     SORT WIRE-SORT ASCENDING KEY
002680     CONN1 CONN2
002690     INPUT PROCEDURE PROC-A  GIVING T-DISK.
002700     GO TO WIRE-TAPE-SORT.
002710 PROC-A SECTION.
002720 P-A.
002730     READ DATA-CRDS AT END GO TO P-A-EX.
002740     MOVE SPACE TO GSE-FLAG.
002750     IF ACT IN IN-CARDS = 'A' OR 'D' NEXT SENTENCE
002760         ELSE
002770         MOVE 'ILLEGAL ACTION CODE ' TO ERR-MSG,
002780         GO TO REPORT-ERROR.
002790     IF FCONN IN IN-CARDS = SPACES
002800         MOVE 'FROM CONNECTOR BLANK' TO ERR-MSG,
002810         GO TO REPORT-ERROR.
002820     IF TCONN IN IN-CARDS = SPACES
002830         MOVE 'TO CONNECTOR BLANK  ' TO ERR-MSG,
002840         GO TO REPORT-ERROR.
002850     IF FCNTR IN IN-CARDS = 'N' NEXT SENTENCE
002860         ELSE GO TO PROCESS-CARD.
002870     IF FAREA IN IN-CARDS = 'G' NEXT SENTENCE
002880         ELSE
002890         GO TO PROCESS-CARD.
002900     IF FBAY-NO IN IN-CARDS = SPACES
002910         MOVE 'FROM BAY NO. BLANK  ' TO ERR-MSG,
002920         GO TO REPORT-ERROR.
002930     IF TBAY-NO IN IN-CARDS = SPACES
002940         MOVE 'TO BAY NO. BLANK    ' TO ERR-MSG,
002950         GO TO REPORT-ERROR.
002960     MOVE GSE-FROM-AH IN IN-CARDS TO GSE-FROM-AH IN HOLD-SRT.
002970     MOVE '$' TO GSE-FLAG.
002980 PROCESS-CARD.
002990     MOVE CORRESPONDING IN-CARDS  TO HOLD-SRT.
003000     MOVE HOLD-SRT TO SRT-WIRE.
003010     MOVE SPACE TO DUP.
003020     RELEASE SRT-WIRE
003030     MOVE HOLD-SRT TO SRT-WIRE.
003040     MOVE '*' TO DUP.
003050     MOVE FCNTR OF HOLD-SRT TO TO-CONT.
003060     MOVE FAREA OF HOLD-SRT TO TO-AREA.
003070     MOVE FITEM OF HOLD-SRT TO TO-TYPE.
003080     MOVE FBAY-NO OF HOLD-SRT TO T-BAY.
003090     MOVE FPIN  OF HOLD-SRT TO TO-PIN.
003100     MOVE TCNTR OF HOLD-SRT TO F-CONT.
003110     MOVE TAREA OF HOLD-SRT TO F-AREA.
003120     MOVE TITEM OF HOLD-SRT TO F-TYPE.
003130     MOVE TBAY-NO OF HOLD-SRT TO F-BAY.
003140     MOVE TPIN  OF HOLD-SRT TO F-PIN.
003150     MOVE AREA-S IN HOLD-SRT TO TO-AREA-HARNESS.
003160     MOVE GSE-TO-AH IN HOLD-SRT TO FROM-AREA-HARNESS.
003170         RELEASE SRT-WIRE GO TO P-A.
003180 REPORT-ERROR.
003190     MOVE IN-CARDS TO ERR-RCD.
003200     WRITE ERROR-RCD.
003210     COMPUTE NERRS = NERRS + 1.
003220     GO TO P-A.
003230 P-A-EX.
003240     CLOSE DATA-CRDS.
003250     DISPLAY 'NO. EDIT ERRORS FOUND = ' NERRS.
003260     MOVE 0 TO NERRS.
003270 WIRE-SRT SECTION.
003280 WIRE-TAPE-SORT.
003290     SORT WIRE-SORT ASCENDING KEY
003300     CONN1 CONN2
003310     INPUT PROCEDURE PROC-1      OUTPUT PROCEDURE PROC-2.
003320     GO TO END-UP.
003330 PROC-1 SECTION.
003340     OPEN INPUT NA-TAPE.
003350 P-1.
003360     MOVE SPACE TO HOLD-OUT.
003370     READ NA-TAPE INTO SRT-WIRE AT END
003380     CLOSE NA-TAPE
003390     GO TO RD-GR.
003400         RELEASE SRT-WIRE GO TO P-1.
003410 RD-GR.
003420     OPEN INPUT GRUM-TAPE.
003430 P-2.
003440     READ GRUM-TAPE INTO SRT-WIRE AT END
003450     CLOSE GRUM-TAPE
003460     GO TO RD-GSE.
003470         RELEASE SRT-WIRE GO TO P-2.
003480 RD-GSE.
003490     OPEN INPUT GSE-TAPE.
003500 P-3.
003510     READ GSE-TAPE INTO SRT-WIRE AT END
003520     CLOSE GSE-TAPE
003530     GO TO PROC-1-EX.
003540         RELEASE SRT-WIRE GO TO P-3.
003550 PROC-1-EX.
003560     EXIT.
003570 PROC-2 SECTION.
003580     OPEN INPUT T-DISK.
003590     OPEN OUTPUT WIREMERG. OPEN OUTPUT WIRE-RPT.
003600     ALTER P-4 TO PROCEED TO RTN-RCD.
003610     ALTER SW TO PROCEED TO GET-TR.
003620     ALTER TSTSW TO PROCEED TO TST.
003630 P-4.
003640     GO TO.
003650 RTN-RCD.
003660     RETURN WIRE-SORT AT END
003670         GO TO EOF-WIRE-LIST.
003680     COMPUTE NRRD = NRRD + 1.
003690 SW.
003700     GO TO.
003710 GET-TR.
003720     READ T-DISK INTO HOLD-ACTION AT END
003730         GO TO EOF-TR.
003740 TSTSW.
003750     GO TO.
003760 TST.
003770     IF TRANS-FROM GREATER CONN1
003780         ALTER SW TO PROCEED TO TST,
003790         ALTER P-4 TO PROCEED TO RTN-RCD,
003800         GO TO MK-149.
003810     IF TRANS-FROM = CONN1 NEXT SENTENCE
003820         ELSE GO TO ADD-RECORD.
003830     IF TRANS-TO GREATER CONN2
003840         ALTER SW TO PROCEED TO TST,
003850         ALTER P-4 TO PROCEED TO RTN-RCD,
003860         GO TO MK-149.
003870     IF TRANS-TO = CONN2 GO TO DELETE-RECORD.
003880 ADD-RECORD.
003890     IF ACC = 'A' NEXT SENTENCE
003900         ELSE
003910         MOVE 'DELETE - NO RECORD  ' TO ERR-MSG,
003920         GO TO REPORT-ERR.
003930     MOVE TRANS-FROM TO CONN1H.
003940     MOVE TRANS-TO TO CONN2H.
003950     MOVE REMRKS TO REMRKH.
003960     MOVE DUPH TO DUP2.
003970     MOVE GSE-RCD TO F6.
003980     IF GSE-RCD = '$' MOVE FR-AREAH TO GSE-FROM-AREA-HARNESS
003990         ELSE
004000         MOVE REFDES TO AREAHH.
004010     MOVE 'RECORD ADDED        ' TO ERR-MSG.
004020     MOVE HOLD-ACTION TO ERR-RCD.
004030     WRITE ERROR-RCD.
004040     ALTER P-4 TO PROCEED TO GET-TR.
004050     COMPUTE NRADD = NRADD + 1.
004060     GO TO WRITE-RECORD.
004070 DELETE-RECORD.
004080     IF ACC = 'D' NEXT SENTENCE
004090         ELSE
004100         MOVE 'ADD - RECORD EXISTS ' TO ERR-MSG,
004110         GO TO REPORT-ERR.
004120     MOVE 'RECORD DELETED      ' TO ERR-MSG.
004130     MOVE HOLD-ACTION TO ERR-RCD.
004140     WRITE ERROR-RCD.
004150     ALTER SW TO PROCEED TO GET-TR.
004160     ALTER P-4 TO PROCEED TO RTN-RCD.
004170     COMPUTE NRDEL = NRDEL + 1.
004180     GO TO P-4.
004190 REPORT-ERR.
004200     MOVE HOLD-ACTION TO ERR-RCD.
004210     WRITE ERROR-RCD.
004220     COMPUTE NERRS = NERRS + 1.
004230     GO TO GET-TR.
004240 EOF-WIRE-LIST.
004250     IF EOF-SW = '0' NEXT SENTENCE
004260         ELSE
004270         GO TO PROC-2-EX.
004280     MOVE '1' TO EOF-SW.
004290     ALTER TSTSW TO PROCEED TO ADD-RECORD.
004300     GO TO ADD-RECORD.
004310 EOF-TR.
004320     IF EOF-SW = '0' NEXT SENTENCE
004330         ELSE
004340         GO TO PROC-2-EX.
004350     MOVE '1' TO EOF-SW.
004360     ALTER P-4 TO PROCEED TO RTN-RCD.
004370     ALTER SW TO PROCEED TO MK-149.
004380 MK-149.
004390     IF DUP = '*'
004400     MOVE SPACE TO DUP
004410     MOVE '*' TO DUP2
004420     ELSE MOVE SPACE TO DUP2
004430     MOVE CONN1 TO CONN1H.
004440     MOVE CONN2 TO CONN2H.
004450     IF GSE-INDICATE = '$'
004460         MOVE FROM-AREA-HARNESS TO GSE-FROM-AREA-HARNESS
004470         MOVE F1 TO F4
004480         MOVE F2 TO F5
004490         MOVE F3 TO F6
004500         ELSE
004510         MOVE ROMRKS TO REMRKH
004520         MOVE FROM-AREA-HARNESS TO AREAHH.
004530 WRITE-RECORD.
004540     WRITE MASTWIRE FROM HOLD-OUT.
004550     COMPUTE NRWR = NRWR + 1.
004560     GO TO CON-CHECK.
004570 PROC-2-EX.
004580     CLOSE T-DISK.
004590     WRITE LINER FROM BLNK AFTER 0.
004600 ENDY SECTION.
004610 CON-CHECK.
004620     IF F-CONT = 'G' GO TO GR-CHECK ELSE GO TO NA-CHECK.
004630 GR-CHECK.
004640     IF LN-CNT GREATER MAX PERFORM EJECTO.
004650     IF F-CONT = WS-CONT NEXT SENTENCE ELSE MOVE 'Z' TO WS-AREA.
004660     MOVE '    GRUMMAN   ' TO VENDOR.
004670     MOVE 'DESIGNATOR' TO DES-NET.
004680     IF F-AREA = WS-AREA NEXT SENTENCE ELSE
004690             PERFORM EJECTO PERFORM FIND-AREA THRU FIND-OUT.
004700     IF HD = 1 MOVE 0 TO HD PERFORM WRITE-HEADERS.
004710             PERFORM MOVE-DATA GO TO P-4.
004720 NA-CHECK.
004730     IF LN-CNT GREATER MAX PERFORM EJECTO.
004740     IF F-CONT = WS-CONT NEXT SENTENCE ELSE MOVE 'Z' TO WS-AREA.
004750     MOVE 'NORTH AMERICAN' TO VENDOR
004760     MOVE 'DESIGNATOR' TO DES-NET.
004770     IF F-AREA = WS-AREA NEXT SENTENCE ELSE
004780             PERFORM EJECTO  PERFORM FIND-AREA THRU FIND-OUT.
004790     IF HD = 1 MOVE 0 TO HD PERFORM WRITE-HEADERS.
004800             PERFORM MOVE-DATA GO TO P-4.
004810 FIND-AREA.
004820     IF F-AREA = 'C' MOVE '(CM)        ' TO A-CODE
004830                     MOVE 'C' TO WS-AREA GO TO FIND-OUT.
004840     IF F-AREA = 'G' MOVE '(GSE)        ' TO A-CODE
004850                     MOVE 'G' TO WS-AREA GO TO FIND-OUT.
004860     IF F-AREA = 'L' MOVE '(LM)        ' TO A-CODE
004870                     MOVE 'L' TO WS-AREA GO TO FIND-OUT.
004880     IF F-AREA = 'S' MOVE '(SM)        ' TO A-CODE
004890                     MOVE 'S' TO WS-AREA GO TO FIND-OUT.
004900     IF F-AREA = 'A' MOVE '(SLA)       ' TO A-CODE
004910                     MOVE 'A' TO WS-AREA GO TO FIND-OUT.
004920     IF F-AREA = 'E' MOVE '(LET)        ' TO A-CODE
004930                     MOVE 'E' TO WS-AREA GO TO FIND-OUT.
004940 FIND-OUT.
004950     EXIT.
004960 WRITE-HEADERS.
004970     WRITE LINER FROM DTLINE AFTER 2.
004980     WRITE LINER FROM RPT-NAME AFTER 2.
004990     WRITE LINER FROM VEND-LINE AFTER 1.
005000     WRITE LINER FROM AST-LINE AFTER 2.
005010     WRITE LINER FROM HEAD1 AFTER 1.
005020     WRITE LINER FROM FR-TO AFTER 1.
005030     WRITE LINER FROM SEP AFTER 1.
005040     WRITE LINER FROM HEAD2 AFTER 1.
005050     WRITE LINER FROM AST-LINE AFTER 1.
005060     WRITE LINER FROM BLNK AFTER 1.
005070     ADD 12 TO LN-CNT.
005080 MOVE-DATA.
005090     MOVE F-CONT TO WS-CONT.
005100     MOVE FROM-REF TO WR-FR-REF.
005110     MOVE F-PIN TO WR-FR-PIN.
005120     MOVE TO-REF TO WR-TO-REF.
005130     MOVE TO-PIN TO WR-TO-PIN.
005140     MOVE FROM-AREA-HARNESS TO WR-DES.
005150     EXAMINE WR-TO-PIN REPLACING LEADING ZEROES BY SPACES.
005160     MOVE SPACE TO WR-RMKS.
005170     MOVE ROMRKS TO WR-RMKS.
005180     EXAMINE WR-FR-PIN REPLACING LEADING ZEROES BY SPACES.
005190     WRITE LINER FROM DATA-LINE AFTER 1 ADD 1 TO LN-CNT.
005200 EJECTO.
005210     WRITE LINER FROM BLNK AFTER 0
005220     MOVE 1 TO HD  ADD 1 TO PG-NO
005230     MOVE 0 TO LN-CNT.
005240 END-UP.
005250     CLOSE WIREMERG WIRE-RPT ERROR-FILE.
005260     DISPLAY 'RECORDS ADDED   = ' NRADD.
005270     DISPLAY 'RECORDS DELETED = ' NRDEL.
005280     DISPLAY 'RECORDS READ    = ' NRRD.
005290     DISPLAY 'RECORDS WRITTEN = ' NRWR.
005300     DISPLAY 'UPDATE ERRORS   = ' NERRS.
005310     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.         ILDISCNT.
000030 AUTHOR.             JESSE VAWTER.
000040 DATE-WRITTEN.       JANUARY 1969.
000050 REMARKS.
000060     THIS PROGRAM RESTORES LOGICAL CONTINUITY OF CIRCUITRY ACROSS
000070     BULK-HEADS, PRODUCTION BREAKS, AND/OR UMBILICAL DISCONNECTS.
000080     THIS PROGRAM READS A SEGMENT, IF THE FIRST CHARACTER OF THE
000090     FROM- OR TO- ITEM IS EITHER 'P' OR 'J', THE TABLE OF IN-LINE
000100     DISCONNECTS (FROM-SIDE) IS SEARCHED. IF A MATCH FOR THE
000110     CONNECTOR IS FOUND, THE TO-SIDE OF THE IN-LINE DISCONNECT
000120     VALUE IS SUBSTITUTED FOR THE FROM- OR TO- CONNECTOR
000130     INVOLVED.
000140 ENVIRONMENT DIVISION.
000150 CONFIGURATION SECTION.
000160 SOURCE-COMPUTER.    IBM-360.
000170 OBJECT-COMPUTER.    IBM-360.
000180 INPUT-OUTPUT SECTION.
000190 FILE-CONTROL.
000200     SELECT  WIR-LST         ASSIGN TO UT-S-WINPT.
000210     SELECT  WIRE-LIST-OUT   ASSIGN TO UT-S-WOTPT.
000220     SELECT  INCARD          ASSIGN TO UT-S-CRDS.
000230 DATA DIVISION.
000240 FILE SECTION.
000250 FD  INCARD
000260     RECORDING MODE IS F
000270     LABEL RECORDS ARE OMITTED
000280     BLOCK CONTAINS 1 RECORDS
000290     DATA RECORD IS CARD-IN.
000300 01  CARD-IN.
000310     02  FILLER      PICTURE X(80).
000320 FD  WIR-LST
000330     LABEL RECORDS ARE OMITTED
000340     RECORDING MODE IS F
000350     BLOCK CONTAINS 10 RECORDS
000360     DATA RECORD IS WLI.
000370 01  WLI.
000380     02  FILLER      PICTURE X(149).
000390 FD  WIRE-LIST-OUT
000400     RECORDING MODE IS F
000410     LABEL RECORDS ARE OMITTED
000420     BLOCK CONTAINS 10 RECORDS
000430     DATA RECORD IS WLO.
000440 01  WLO.
000450     02  FILLER      PICTURE X(149).
000460 WORKING-STORAGE SECTION.
000470 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000480 77  I           PICTURE 999     VALUE ZERO.
000490 77  J           PICTURE 999     VALUE ZERO.
000500 01  ARRAY-DATA-TABLE.
000510     02  TABL-ITEM OCCURS 300 TIMES.
000520         03  TABL-FROM   PICTURE X(11).
000530         03  TABL-TO     PICTURE X(11).
000540 01  CARDD.
000550     02  DATA-IN         PICTURE X(22).
000560     02  FILLER          PICTURE X(58).
000570 01  WS-WL.
000580     02  FILLER     PICTURE X(15).
000590     02  WS-FROM.
000600         03  FILLER     PICTURE X(2).
000610         03  F-ITEM.
000620             04  FI1         PICTURE X.
000630             04  FILLER      PICTURE X(8).
000640     02  FILLER              PICTURE X.
000650     02  F-PIN               PICTURE X(4).
000660     02  WS-TO.
000670         03  FILLER          PICTURE X(2).
000680         03  T-ITEM.
000690             04  TI1         PICTURE X.
000700             04  FILLER      PICTURE X(8).
000710     02  FILLER              PICTURE X(107).
000720 PROCEDURE DIVISION.
000730     OPEN INPUT INCARD.
000740     OPEN INPUT WIR-LST.
000750     OPEN OUTPUT WIRE-LIST-OUT.
000760 READ-CARD.
000770     READ INCARD INTO CARDD AT END GO TO READ-WIRE-LIST.
000780     ADD 1 TO I.
000790     MOVE DATA-IN TO TABL-ITEM (I).
000800     GO TO READ-CARD.
000810 READ-WIRE-LIST.
000820     MOVE SPACES TO WS-WL.
000830     READ WIR-LST INTO WS-WL AT END GO TO END-OF-JOB.
000840     IF  (FI1 = 'P' OR FI1 = 'J' OR TI1 = 'P' OR TI1 = 'J')
000850         NEXT SENTENCE
000860       ELSE  WRITE WLO FROM WS-WL GO TO READ-WIRE-LIST.
000870 CHECK-FI1.
000880     IF FI1 = 'P' OR FI1 = 'J' GO TO CHECK-FROM
000890        ELSE GO TO CHECK-TI1.
000900 CHECK-FROM.
000910     MOVE 1 TO J.
000920 CHECK-WS-FROM.
000930     IF TABL-FROM (J) = WS-FROM MOVE TABL-TO (J) TO WS-FROM
000940         GO TO CHECK-TI1.
000950     ADD 1 TO J.
000960     IF J < I GO TO CHECK-WS-FROM ELSE GO TO CHECK-TI1.
000970 CHECK-TI1.
000980     IF (TI1 = 'P' OR TI1 = 'J') NEXT SENTENCE
000990       ELSE
001000             WRITE WLO FROM WS-WL
001010             GO TO READ-WIRE-LIST.
001020     MOVE 1 TO J.
001030 CHECK-WS-TO.
001040     IF TABL-FROM (J) = WS-TO  MOVE TABL-TO (J) TO WS-TO
001050             WRITE WLO FROM WS-WL
001060             GO TO READ-WIRE-LIST.
001070     ADD 1 TO J.
001080     IF J < I  GO TO CHECK-WS-TO
001090        ELSE
001100             WRITE WLO FROM WS-WL
001110             GO TO READ-WIRE-LIST.
001120 END-OF-JOB.
001130     CLOSE WIR-LST.
001140     CLOSE WIRE-LIST-OUT.
001150     CLOSE INCARD.
001160     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. MERBB.
000030 AUTHOR. A GUILLORY.
000040 DATE-WRITTEN. OCTOBER 10 1968.
000050 INSTALLATION. THE BOEING COMPANY HOUSTON, TEXAS.
000060 REMARKS.     THIS PROGRAM HAS TWO FUNCTIONS. THESE ARE WITH
000070         RESPECT TO THE INPUT AND OUTPUT PROCEDURES
000080         1.   INPUT PROCEDURE ( 4 FUNCTIONS WITHIN ) -
000090
000100           A.      TO ASSIGN A FROM CONNECTOR, BOX REF DES NUMBER
000110              TO EACH FROM / BOX
000120
000130           B.      TO ASSIGN A SWITCH INDICATOR (S) FOR A CONNECT
000140             -OR  FOUND TO BE A SWITCH (EITHER AN S OR CB TYPE
000150              ITEM WITH FROM = TO CONNECTOR)
000160
000170           C.      TO OUTPUT THE BID / BED MERGED OUTPUT WHICH IS
000180              IN FROM CONNECTOR , BOX REF DES SEQUENCE
000190
000200           D.      TO RELEASE TO THE INTERNAL SORT THE RECORDS
000210              ( EDITED WITH RESPECT TO GSE - (GSE RECORDS (BED
000220              TYPES ONLY) EDITED) TO BE SORTED ON TO CONNECTOR
000230              AND BOX REF DES FOR THE OUTPUT PROCEDURE INPUT.
000240
000250
000260         2.   OUTPUT PROCEDURE ( 1 FUNCTION WITHIN ) -
000270
000280           A.      TO ASSIGN A TO CONNECTOR, BOX REF DES NUMBER
000290              TO EACH  TO CONN / BOX.
000300
000310 ENVIRONMENT DIVISION.
000320 CONFIGURATION SECTION.
000330 SOURCE-COMPUTER. IBM-360.
000340 OBJECT-COMPUTER. IBM-360.
000350 INPUT-OUTPUT SECTION.
000360 FILE-CONTROL.
000370     SELECT  MERG-TP ASSIGN  TO  UT-S-BBINTP.
000380     SELECT   FIN-TP ASSIGN  TO  UT-S-FINAL.
000390     SELECT  INCD    ASSIGN  TO  UT-S-OPTCD.
000400     SELECT  MESSAG  ASSIGN  TO  UT-S-MESSAG.
000410     SELECT  SRTIN   ASSIGN TO UT-S-SD1.
000420 DATA DIVISION.
000430 FILE SECTION.
000440 FD  MERG-TP
000450     RECORDING MODE IS F
000460     LABEL RECORDS ARE OMITTED
000470     BLOCK CONTAINS  10  RECORDS
000480     DATA RECORD IS  BID-R.
000490 01  BID-R               PICTURE X(149).
000500 FD  FIN-TP
000510     RECORDING MODE IS F
000520     BLOCK CONTAINS  10  RECORDS
000530     LABEL RECORDS ARE OMITTED
000540     DATA RECORD IS  FIN-R.
000550 01  FIN-R               PICTURE X(162).
000560 FD  INCD
000570     RECORDING  MODE IS  F
000580     LABEL RECORDS ARE OMITTED
000590     DATA RECORD IS  OPT-R.
000600 01  OPT-R.
000610  02 FILLER              PICTURE X(6).
000620  02 DAT-R               PICTURE X(8).
000630   02 FILLER             PICTURE X(5).
000640  02 SP-CRT-1            PICTURE X(3).
000650  02 FILLER              PICTURE X(5).
000660  02 SP-CRT-2            PICTURE X(3).
000670  02 FILLER              PICTURE X(50).
000680 FD  MESSAG
000690     RECORDING  MODE IS  F
000700     BLOCK  CONTAINS  10  RECORDS
000710     LABEL RECORDS  ARE  OMITTED
000720     DATA RECORD IS  MESS-1.
000730 01  MESS-1              PICTURE X(132).
000740 SD  SRTIN       RECORDING  MODE  IS  F
000750     RECORD CONTAINS 162 CHARACTERS
000760     DATA  RECORD IS SOUT.
000770 01  SOUT.
000780  02 FILLER              PICTURE X(13).
000790  02 BRDS                PICTURE X(15).
000800  02 FILLER              PICTURE X(16).
000810  02 TO-CS               PICTURE X(16).
000820  02 FILLER              PICTURE X(102).
000830 WORKING-STORAGE SECTION.
000840 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000850 77  I                   PICTURE 9(6) VALUE ZERO.
000860 77  SEG-NO              PICTURE 9(6) VALUE ZERO.
000870 77  PWR-NO                  PICTURE 9(6)  VALUE ZERO.
000880 77  GND-NO                  PICTURE 9(6)  VALUE ZERO.
000890 77  DISP-O3             PICTURE 9(6) VALUE ZERO.
000900 77  J                   PICTURE 9(6)   VALUE ZERO.
000910 77  WSBOX               PICTURE X(15) VALUE SPACES.
000920 77  PAGE-CT             PICTURE 9(4) VALUE ZERO.
000930 77  LIN-C               PICTURE 99      VALUE ZERO.
000940 77  ENDIT               PICTURE 9   VALUE ZERO.
000950 01  PRT-AREA.
000960  02 FILLER              PICTURE X       VALUE SPACES.
000970  02 BOX-RF              PICTURE X(15).
000980  02 FILLER              PICTURE X       VALUE SPACES.
000990  02 FCON                PICTURE X(16).
001000  02 FILLER              PICTURE X       VALUE SPACES.
001010  02 TCON                PICTURE X(16).
001020  02 FILLER              PICTURE X       VALUE SPACES.
001030  02 DIO                 PICTURE X.
001040  02 FILLER              PICTURE X       VALUE SPACES.
001050  02 IMP                 PICTURE XXX.
001060  02 FILLER              PICTURE X       VALUE SPACES.
001070  02 DWG-NO              PICTURE X(21).
001080  02 FILLER              PICTURE XX  VALUE SPACES.
001090  02 AR-HARN             PICTURE X(7).
001100  02 FILLER              PICTURE XX  VALUE SPACES.
001110  02 BIDRMKS              PICTURE X(38).
001120  02  FILLER             PICTURE X VALUE SPACES.
001130  02 DUP-2               PICTURE X.
001140 01  HD-1.
001150  02 FILLER              PICTURE X(66)   VALUE SPACES.
001160  02 FILLER              PICTURE X(3)    VALUE 'BID'.
001170 01  HD-2.
001180  02 FILLER              PICTURE X(57)   VALUE SPACES.
001190  02 FILLER              PICTURE X(73)   VALUE '***DRAWING NUMBER*
001200-    '***                                                    '.
001210 01  HD-3.
001220  02 FILLER              PICTURE X(6)    VALUE SPACES.
001230  02 FILLER              PICTURE X(54)   VALUE 'BOX        CA   FR
001240-    'OM        CA    TO         D     *  '.
001250  02 FILLER              PICTURE X(17)   VALUE SPACES.
001260  02 FILLER              PICTURE X(09) VALUE '*    AREA'.
001270 01  HD-4.
001280  02 FILLER              PICTURE X(3)    VALUE SPACES.
001290  02 FILLER              PICTURE X(57)   VALUE 'REF   DES     OC
001300-    'NUMBER  PIN  OC  NUMBER  PIN  I IMP *  '.
001310  02 FILLER              PICTURE X(17) VALUE SPACES.
001320  02 FILLER              PICTURE X(13) VALUE '*  HARNESS  B'.
001330  02 FILLER              PICTURE X(27) VALUE ' I D / B E D  R E M
001340-    'A R K S'.
001350 01  HD-5.
001360  02 FILLER              PICTURE X(10)  VALUE  SPACES.
001370  02 FILLER              PICTURE X(18) VALUE ' NORTH AMERICAN   '.
001380  02 SP-CRT-NO1          PICTURE X(3).
001390  02 FILLER              PICTURE X(6) VALUE '  LM  '.
001400  02 SP-CRT-NO2          PICTURE X(3).
001410  02 FILLER              PICTURE X(49) VALUE SPACES.
001420  02 FILLER              PICTURE X(12)   VALUE 'REPORT DATE '.
001430  02 DAT-P               PICTURE X(8).
001440  02 FILLER              PICTURE X(7)    VALUE '  PAGE '.
001450  02 PG-NO               PICTURE ZZ99.
001460 01  HD-DD.
001470  02 FILLER              PICTURE X(132)  VALUE SPACES.
001480 01  BID-BED.
001490     02  FROM-NO                     PICTURE 9(6).
001500     02  TO-NO                       PICTURE 9(6).
001510     02  SWITCH                      PICTURE X.
001520     02  BB-HOLD.
001530         03  BOX-R.
001540             04  FILLER              PICTURE X(11).
001550             04  BOX12-15            PICTURE X(4).
001560         03  FROM-C.
001570             04  SWITCH-FR.
001580                 05  FILLER          PICTURE XX.
001590                 05  PWRGF.
001600                     06  PJ-FR.
001610                         07  PJ-FR1  PICTURE X.
001620                         07  FILLER  PICTURE X.
001630                     06  FILLER      PICTURE X(3).
001640                 05  FILLER          PICTURE X(5).
001650             04  FILLER              PICTURE X(4).
001660         03  TO-C.
001670             04  SWITCH-TO.
001680                 05  COACT           PICTURE XX.
001690                 05  PWRGT.
001700                     06  PJ-TO.
001710                         07  PJ-TO1  PICTURE X.
001720                         07  FILLER  PICTURE X.
001730                     06  FILLER      PICTURE X(3).
001740                 05  FILLER          PICTURE X(5).
001750             04  FILLER              PICTURE X(4).
001760         03  DIODE                   PICTURE X.
001770         03  IMPED                   PICTURE X(3).
001780         03  BID-DAT.
001790             04  DWG-NOH             PICTURE X(21).
001800             04  PRT-NO              PICTURE X(20).
001810             04  BX-TIT              PICTURE X(19).
001820             04  BID-RMK             PICTURE X(38).
001830         03  BED-DAT  REDEFINES BID-DAT.
001840                 04  A-HARN          PICTURE X(15).
001850                 04  BED-RMK.
001860                     05  FILLER      PICTURE X(26).
001870                     05  BED-A-H     PICTURE X(11).
001880                     05  MARK-T      PICTURE X.
001890                 04  FILLER          PICTURE X(44).
001900                 04  DUP             PICTURE X.
001910 01  GROUP1.
001920  02 ARRAY1 OCCURS 200 TIMES.
001930     03  FROM-NOA                    PICTURE 9(6).
001940     03  TO-NOA                      PICTURE 9(6).
001950     03  FILLER                      PICTURE X.
001960     03  BB-HOLDA.
001970         04  BOX-RA                  PICTURE X(15).
001980         04  FROM-CA                 PICTURE X(16).
001990         04  TO-CA.
002000             05  COACTA              PICTURE XX.
002010             05  FILLER              PICTURE X(14).
002020         04  DIODEA                  PICTURE X.
002030         04  IMPEDA                  PICTURE X(3).
002040         04  BID-DATA                PICTURE X(98).
002050 01  B-B-DAT.
002060     02  BID-D.
002070         03  DWG-NOHA                PICTURE X(21).
002080         03  FILLER                  PICTURE X(39).
002090         03  BID-RMKA                PICTURE X(38).
002100     02  BED-D   REDEFINES   BID-D.
002110         03  A-HARNA                 PICTURE X(15).
002120         03  BED-RMKA.
002130             04  FILLER              PICTURE X(26).
002140             04  BED-A-HA            PICTURE X(11).
002150             04  MARK-TA             PICTURE X.
002160         03  FILLER                  PICTURE X(44).
002170         03  DUPA                    PICTURE X.
002180 PROCEDURE DIVISION.
002190     OPEN  INPUT MERG-TP.
002200     OPEN  OUTPUT FIN-TP.
002210     OPEN  INPUT INCD.
002220     OPEN OUTPUT MESSAG.
002230     NOTE  1  ---------------------------------------------------
002240           1
002250           1       INCD  CONTAINS THE SPACECRAFTS BEING PROCESSED
002260           1  SP-CRT-2  =    LM (GRUMMAN LEM)
002270           1  SP-CRT-1  =    CSM ( NORTH AMERICAN COMMAND MODULE)
002280           1       AND  THE CURRENT DATE AS MM-DD-YY
002290           1
002300           1  --------------------------------------------------.
002310     READ INCD AT END CLOSE MERG-TP
002320                         CLOSE FIN-TP
002330                       CLOSE MESSAG
002340                       CLOSE INCD
002350                       DISPLAY ' NEED DATE AND SPACECRAFT '
002360                       DISPLAY ' INPUT CARD ON OPTCD DD * DATA'
002370                       DISPLAY ' SET '
002380                       STOP RUN.
002390     MOVE  DAT-R  TO  DAT-P
002400     MOVE  SP-CRT-1  TO  SP-CRT-NO1
002410     MOVE  SP-CRT-2  TO  SP-CRT-NO2
002420     CLOSE  INCD
002430     PERFORM N-PG0.
002440     SORT SRTIN   ASCENDING KEY
002450         TO-CS  BRDS
002460     INPUT PROCEDURE INITIAL-S   THRU INIT-EXIT
002470     OUTPUT PROCEDURE FINAL-S    THRU FINAL-EX.
002480     DISPLAY  ' TOTAL POWERS  =   '    PWR-NO.
002490     DISPLAY  ' TOTAL GROUND  =   '    GND-NO.
002500     DISPLAY  ' LARGEST NODE  =   '    DISP-O3.
002510         CLOSE  FIN-TP.
002520         STOP RUN.
002530 INITIAL-S SECTION.
002540 RD-MER.
002550     IF  ENDIT  =  5
002560         PERFORM N-PG  THRU  N-PG0
002570         CLOSE MESSAG
002580         GO  TO  INIT-EXIT.
002590     READ MERG-TP  INTO  BB-HOLD  AT  END
002600             CLOSE  MERG-TP
002610             MOVE  5  TO  ENDIT
002620             GO  TO  DONE-ONE.
002630     NOTE  2  ---------------------------------------------------
002640           2
002650           2       ALL POWERS (PWR) ARE GIVEN THE FROM NUMBER
002660           2  ONE, WHILE GROUNDS (GND) ARE ASSIGNED THE NUMBER
002670           2  TWO -- THE SAME IS TRUE FOR PWRS AND GNDS ON THE
002680           2  TO CONNECTOR SIDE -- IT IS IMPOSSIBLE FOR A SWITCH
002690           2  CONDITION TO EXIST  AS   POWER IS  P NOT S OR CB
002700           2  TYPE
002710           2
002720           2  --------------------------------------------------.
002730     MOVE  SPACES  TO  BOX12-15.
002740     IF  PWRGF  =  '  PWR'   MOVE  1  TO  FROM-NO
002750         MOVE  SPACES  TO  SWITCH
002760         PERFORM  WRT-RPT-A  THRU  WRT-RPT-DON
002770         ADD  1  TO  PWR-NO
002780         PERFORM  GSE-PWRGN  THRU  PWR-GN-EX
002790         MOVE  BID-BED  TO  SOUT
002800         RELEASE  SOUT
002810         GO  TO  RD-MER.
002820     IF  PWRGF  =  ' GND '    MOVE  2  TO  FROM-NO
002830         MOVE  2  TO  SEG-NO
002840         MOVE  SPACES  TO  SWITCH
002850         PERFORM  WRT-RPT-A  THRU  WRT-RPT-DON
002860         ADD  1  TO  GND-NO
002870         PERFORM  GSE-PWRGN  THRU  PWR-GN-EX
002880         MOVE  BID-BED  TO  SOUT
002890         RELEASE  SOUT
002900         GO  TO  RD-MER.
002910     MOVE  SPACES  TO  SWITCH
002920     IF  PJ-FR  =  'CB'  OR   PJ-FR1  =  'S'
002930         NEXT  SENTENCE  ELSE
002940         GO  TO  NON-SWITCH.
002950     NOTE  3  ---------------------------------------------------
002960           3
002970           3       SWITCH CONDITION EXIST IF THE CONNECTOR IS AN
002980           3  S OR CB TYPE -- IF IT IS THEN FROM CONNECTOR IS
002990           3  TESTED AGAINST TO CONNECTOR-EXCLUDING ONLY THE
003000           3  PIN FIELD IN THE TEST- SHOULD THEY BE EQUAL THEN
003010           3  THE SEGMENT (BRANCH) IS A SWITCH AND IS MARKED
003020           3  WITH SWITCH = 'S'           FROM-C   /     TO-C
003030           3                                       /
003040           3  EXAMPLE: (SWITCH)        NCS01234 AAA/NCS01234 AAA
003050           3                                       /
003060           3           (NON-SWITCH)    NCS01234 AAA/NCS01234 AAB
003070           3
003080           3  --------------------------------------------------.
003090     IF  SWITCH-FR  =  SWITCH-TO    MOVE  'S'  TO  SWITCH.
003100 NON-SWITCH.
003110     IF  I  =  0
003120         MOVE  1  TO  I
003130         MOVE  BID-BED  TO  ARRAY1 (1)
003140         GO  TO  RD-MER.
003150     IF  FROM-C  =  FROM-CA (I)  NEXT  SENTENCE  ELSE
003160         GO  TO  DONE-ONE.
003170     IF  BOX-R  =  BOX-RA (I)  NEXT  SENTENCE  ELSE
003180         GO  TO  CK-DIFF.
003190 LOAD-ARRAY.
003200     ADD  1  TO  I.
003210     IF  I  >  200
003220         DISPLAY  ' NEED MORE ARRAY SPACE IN INITIAL ASSIGN '
003230         CLOSE MESSAG
003240         CLOSE FIN-TP
003250         CLOSE  MERG-TP
003260         STOP RUN.
003270     MOVE  BID-BED  TO  ARRAY1 (I).
003280     GO  TO  RD-MER.
003290 CK-DIFF.
003300     IF  BOX-R  NOT  =  SPACES     GO  TO  EE.
003310         DISPLAY ' SEQUENCE ERROR  IN  BOX REF  INITIAL ASSIGN '
003320         GO  TO  LOAD-ARRAY.
003330 EE.
003340     IF  BOX-RA (I)  NOT  =     SPACES
003350         GO  TO  DONE-ONE.
003360     NOTE  4  ---------------------------------------------------
003370           4
003380           4       SHOULD THE BUFFER (INPUT RECORD) BOX REF NOT =
003390           4  SPACES  AND THE SAME FROM-CONNECTOR (PREVIOUS RECOR
003400           4  D) RECORD BOX REF  BE =  SPACES THE THE FIRST OR
003410           4  THE FIRST AND SECOND CHARACTERS OF THE CURRENT
003420           4  RECORD (FROM CONNECTOR IN INITIAL / TO CONNECTOR IN
003430           4  FINAL) MUST NOT BE EQUAL TO ANY OF THESE SPECIAL
003440           4  CHARACTERS IN ORDER TO ASSIGN THE BED (BOX = SPACES
003450           4  ) RECORD THE SAME FROM (OR TO) NUMBER AS THE BID
003460           4  ( BOX NOT = SPACES)
003470           4
003480           4  EXAMPLE -  BUFFER RECORD  --  ARRAY RECORD
003490           4                            --
003500           4         BOX     FROM-C     --  BOX       FROM-C
003510           4                            --
003520           4         C14A5   J1234-1AB  --            J1234-1AB
003530           4
003540           4  THIS RECORD WOULD BE ASSIGNED THE SAME FROM NUMBER
003550           4
003560           4  THE FOLLOWING RECORD WOULD NOT -
003570           4
003580           4         C14A5   TB0123-ABC --            TB0123-ABC
003590           4
003600           4  --------------------------------------------------.
003610     IF  PJ-FR1  =  'E'  OR =   'N'  OR =   'S'  GO  TO  DONE-ONE.
003620     IF  PJ-FR1  =  '&'  OR =   '#'  OR =   '%'  GO  TO  DONE-ONE.
003630     IF  PJ-FR1  =  '$'  OR =   ','  OR =   '*'  GO  TO  DONE-ONE.
003640     IF  PJ-FR1  =  '+'  OR =   ')'  OR =   ' '  GO  TO  DONE-ONE.
003650     IF  PJ-FR1  =  '('  OR =   '-'  OR =   '@'  GO  TO  DONE-ONE.
003660     IF  PJ-FR1  =  '/'  OR =   '='  OR =   '<'  GO  TO  DONE-ONE.
003670     IF  PJ-FR   =  'TB'     OR  =  'CB'         GO  TO  DONE-ONE.
003680         GO  TO  LOAD-ARRAY.
003690 DONE-ONE.
003700     ADD  1  TO  SEG-NO.
003710     MOVE  1  TO  J.
003720 D-1.
003730     MOVE  SEG-NO  TO  FROM-NOA (J).
003740     PERFORM  WRT-RPT   THRU  WRT-RPT-DON.
003750     IF  COACTA (J) = 'NG'
003760         NEXT  SENTENCE  ELSE
003770         GO  TO  BYE-PAS-GSE.
003780     NOTE  5  ---------------------------------------------------
003790           5
003800           5       GSE (GROUND SUPPORT EQUIPMENT) DATA IS HANDLED
003810           5  IN EXACTLY THE SAME WAY AS ALL OTHER CONTRACTORS
003820           5  EXCEPT FOR OUTPUT
003830           5
003840           5       A CHECK MUST BE MADE FOR BED GSE (MARK-T OR
003850           5  MARK-TA =  $) DATA AND THE TO BOX REF DES (BED-A-HA
003860           5  OR BED-A-H) THEN REPLACES THE CURRENT BOX REF DES
003870           5  DATA -- THIS IS REQUIRED SINCE GSE TO CONNECTORS
003880           5  HAVE REQUIREMENTS FOR A TO-BOX-REF-DES IN ORDER TO
003890           5  BE UNIQUE
003900           5
003910           5  --------------------------------------------------.
003920     MOVE    BID-DATA (J)    TO  B-B-DAT.
003930     IF  MARK-TA      =  '$'  NEXT  SENTENCE  ELSE
003940         GO  TO  BYE-PAS-GSE.
003950     MOVE  SPACES  TO  WSBOX.
003960     MOVE BED-A-HA TO WSBOX.
003970     MOVE BOX-RA (J)  TO  BED-A-HA.
003980     MOVE WSBOX TO BOX-RA (J).
003990     MOVE B-B-DAT TO BID-DATA (J).
004000 BYE-PAS-GSE.
004010     MOVE  ARRAY1 (J)  TO  SOUT.
004020     RELEASE  SOUT.
004030     ADD  1  TO  J.
004040     IF  J  >  I
004050         NEXT  SENTENCE  ELSE  GO  TO  D-1.
004060     IF  I  >   DISP-O3
004070                 MOVE  I  TO  DISP-O3.
004080     MOVE  0  TO  I.
004090     GO  TO  LOAD-ARRAY.
004100 GSE-PWRGN.
004110     IF  COACT   =  'NG'   AND   MARK-T  =  '$'
004120         NEXT  SENTENCE  ELSE  GO  TO  PWR-GN-EX.
004130     NOTE  6  ---------------------------------------------------
004140           6
004150           6       THIS NOTE-6  REFERS BACK TO NOTE-5 EXCEPT
004160           6  THIS SECTION COVERS POWER AND GROUNDS IN GSE
004170           6  BED DATA -- THIS PROBLEM DOES NOT OCCUR IN BIDS
004180           6  BECAUSE THEY ARE ENGINEER DEFINED AND THUS CODED AS
004190           6  CARD INPUT
004200           6
004210           6  --------------------------------------------------.
004220     MOVE  SPACES  TO  WSBOX.
004230     MOVE  BED-A-H  TO  WSBOX.
004240     MOVE  BOX-R  TO  BED-A-H.
004250     MOVE  WSBOX  TO  BOX-R.
004260 PWR-GN-EX.
004270     EXIT.
004280 WRT-RPT-A.
004290     MOVE SPACE TO PRT-AREA.
004300     MOVE    BOX-R       TO      BOX-RF.
004310     MOVE    FROM-C      TO      FCON.
004320     MOVE    TO-C        TO      TCON.
004330     MOVE    DIODE       TO      DIO.
004340     MOVE    IMPED       TO      IMP.
004350     MOVE  SPACES  TO  DUP-2.
004360     NOTE  7  ---------------------------------------------------
004370           7
004380           7       WRT-RPT-A PARAGRAPH USED TO OUTPUT PWRS AND
004390           7  GNDS ON THE MERGE REPORT
004400           7
004410           7  --------------------------------------------------.
004420         IF  BOX-R   =   SPACES  OR  MARK-T  =  '$'
004430             MOVE    A-HARN  TO     AR-HARN
004440             MOVE    BED-RMK  TO      BIDRMKS
004450             MOVE    DUP     TO   DUP-2
004460                   GO  TO  WRT-RPT-A1.
004470     MOVE    DWG-NOH     TO      DWG-NO.
004480     MOVE    BID-RMK     TO       BIDRMKS.
004490     GO  TO  WRT-RPT-A1.
004500 WRT-RPT.
004510     MOVE    BOX-RA (J)     TO  BOX-RF.
004520     MOVE    FROM-CA (J)    TO  FCON.
004530     MOVE    TO-CA (J)      TO  TCON.
004540     MOVE    DIODEA (J)     TO  DIO.
004550     MOVE    IMPEDA (J)     TO  IMP.
004560     MOVE  SPACES  TO  DUP-2.
004570     NOTE  8  ---------------------------------------------------
004580           8
004590           8       WRT-RPT   PARAGRAPH USED TO OUTPUT NON PWRS
004600           8  AND GNDS ON THE MERGE REPORT
004610           8
004620           8  --------------------------------------------------.
004630     MOVE    BID-DATA (J)    TO  B-B-DAT.
004640         IF  BOX-RA (J)  =  SPACES  OR  MARK-TA      =  '$'
004650             MOVE      A-HARNA           TO AR-HARN
004660             MOVE      BED-RMKA          TO BIDRMKS
004670             MOVE      DUPA              TO DUP-2
004680                       GO  TO  WRT-RPT-A1.
004690     MOVE    DWG-NOHA       TO      DWG-NO.
004700     MOVE    BID-RMKA       TO       BIDRMKS.
004710 WRT-RPT-A1.
004720     WRITE   MESS-1   FROM   PRT-AREA    AFTER  1.
004730     ADD  1  TO  LIN-C.
004740     IF   LIN-C  >   50     PERFORM  N-PG  THRU  N-PG0.
004750 WRT-RPT-DON.
004760     EXIT.
004770 N-PG.
004780     ADD  1  TO  PAGE-CT.
004790     MOVE  PAGE-CT  TO  PG-NO.
004800 N-PG0.
004810     WRITE  MESS-1  FROM  HD-DD  AFTER   1.
004820     WRITE  MESS-1  FROM  HD-5   AFTER   1.
004830     WRITE  MESS-1  FROM  HD-1   AFTER   0.
004840     WRITE  MESS-1  FROM  HD-2   AFTER   1.
004850     WRITE  MESS-1  FROM  HD-3   AFTER   1.
004860     WRITE  MESS-1  FROM  HD-4   AFTER   1.
004870     WRITE  MESS-1  FROM  HD-DD  AFTER   2.
004880     MOVE  1 TO  LIN-C.
004890 N-PG0-EX.
004900     EXIT.
004910 INIT-EXIT.
004920     EXIT.
004930 FINAL-S SECTION.
004940     MOVE  0  TO  I.
004950     MOVE  0  TO  J.
004960     MOVE  0  TO  ENDIT.
004970     MOVE 2  TO  SEG-NO.
004980 RET-REC.
004990     IF  ENDIT  =  5   GO  TO  FINAL-EX.
005000     RETURN   SRTIN      AT  END    MOVE  5  TO  ENDIT
005010                                    GO  TO  DONE-TO.
005020     MOVE    SOUT  TO  BID-BED.
005030     NOTE  9  ---------------------------------------------------
005040           9
005050           9       FINAL PHASE SECTION USED TO ASSIGN TO NUMBER
005060           9  TO TO-CONNECTOR  BASIC CONDITIONS REMAIN TRUE
005070           9  FOR TO NUMBER ASSIGNMENT
005080           9
005090           9  --------------------------------------------------.
005100     IF  PWRGT   =   '  PWR'    MOVE  1  TO  TO-NO
005110             PERFORM  TO-PWR-GSE  THRU PWR-G-D
005120             WRITE   FIN-R   FROM   BID-BED
005130             GO  TO  RET-REC.
005140     IF  PWRGT  =  ' GND '    MOVE  2  TO  TO-NO
005150             PERFORM  TO-PWR-GSE  THRU PWR-G-D
005160             WRITE   FIN-R    FROM    BID-BED
005170             GO  TO  RET-REC.
005180     IF  I  =  0     MOVE  1  TO  I
005190                     MOVE  BID-BED  TO  ARRAY1 (1)
005200                     GO  TO  RET-REC.
005210     IF  TO-C    =   TO-CA (I)       NEXT  SENTENCE  ELSE
005220             GO  TO  DONE-TO.
005230     IF   BOX-R   =  BOX-RA (I)     NEXT  SENTENCE  ELSE
005240                                    GO  TO  CK-DIFTO.
005250 LOAD-TO-ARA.
005260     ADD  1  TO  I.
005270     IF  I  >   200
005280         DISPLAY  ' NEED  MORE ARAY SPACE IN FINAL ASSIGN '
005290         DISPLAY  ' SHOULD NEVER HAPPEN UNLESS INITIAL OCCURS '
005300         DISPLAY  ' ALSO -------  '
005310             CLOSE FIN-TP
005320             STOP RUN.
005330     MOVE    BID-BED   TO  ARRAY1 (I).
005340     GO  TO  RET-REC.
005350 CK-DIFTO.
005360     IF  BOX-R   NOT  =  SPACES  GO TO   EE-TO.
005370             DISPLAY ' SEQUENCE  ERROR  IN BOX REF FINAL SECT '
005380             GO  TO  LOAD-TO-ARA.
005390 EE-TO.
005400     IF  BOX-RA (I)  NOT  =  SPACES
005410                     GO  TO  DONE-TO.
005420     IF  PJ-TO1  =  'E'  OR =   'N'  OR =   'S'  GO TO DONE-TO.
005430     IF  PJ-TO1  =  '&'  OR =   '#'  OR =   '%'  GO TO DONE-TO.
005440     IF  PJ-TO1  =  '$'  OR =   ','  OR =   '*'  GO TO DONE-TO.
005450     IF  PJ-TO1  =  '+'  OR =   ')'  OR =   ' '  GO TO DONE-TO.
005460     IF  PJ-TO1  =  '('  OR =   '-'  OR =   '@'  GO TO DONE-TO.
005470     IF  PJ-TO1  =  '/'  OR =   '='  OR =   '<'  GO  TO  DONE-TO.
005480     IF  PJ-TO1  =  '('  OR =   '-'  OR =   '@'  GO  TO  DONE-TO.
005490     IF  PJ-TO   =  'TB' OR =   'CB'             GO TO DONE-TO.
005500     GO  TO  LOAD-TO-ARA.
005510 DONE-TO.
005520     ADD  1  TO  SEG-NO.
005530     MOVE  1  TO  J.
005540 D-2.
005550     MOVE   SEG-NO  TO  TO-NOA (J).
005560     MOVE  BID-DATA (J)  TO  B-B-DAT.
005570     IF  MARK-TA  = '$'  NEXT  SENTENCE  ELSE
005580         GO  TO  SKIP-2-FLP.
005590     MOVE  SPACES  TO  WSBOX.
005600     MOVE BED-A-HA TO WSBOX.
005610     MOVE BOX-RA (J)  TO  BED-A-HA.
005620     MOVE WSBOX TO BOX-RA (J).
005630     MOVE B-B-DAT TO BID-DATA (J).
005640 SKIP-2-FLP.
005650     WRITE  FIN-R   FROM   ARRAY1 (J).
005660     ADD  1  TO  J.
005670     IF   J   >  I
005680         MOVE   0  TO  I
005690         GO  TO  LOAD-TO-ARA.
005700     GO  TO  D-2.
005710 FINAL-EX.
005720     EXIT.
005730 TO-PWR-GSE.
005740     IF  MARK-T  = '$'  NEXT SENTENCE  ELSE
005750         GO  TO  PWR-G-D.
005760     MOVE  SPACES  TO  WSBOX.
005770     MOVE  BED-A-H  TO  WSBOX.
005780     MOVE  BOX-R  TO  BED-A-H.
005790     MOVE  WSBOX  TO  BOX-R.
005800 PWR-G-D.
005810     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. BRXRF.
000030 AUTHOR. RALPH BACK.
000040 INSTALLATION. THE BOEING COMPANY HOUSTON, TEXAS.
000050 REMARKS.
000060                 THIS PROGRAM OUTPUTS TWO DATA SETS, ONE IS A
000070             CROSS REFERENCE DATA SET FOR EACH BRANCH, THE OTHER
000080             IS THE DATA SET NECESSARY FOR BUILDING THE TABLES
000090             FOR THE PATH DERIVATION PROGRAM.
000100             EACH RECORD IS ASSIGNED A SEQUENTIAL BRANCH
000110             NUMBER UPON OUTPUT.
000120             THE REVERSE OF A RECORD IS ELIMINATED.
000130             DUPLICATE POWER-NODE AND GROUND-NODE BRANCHES
000140             ARE ELIMINATED. EACH DUPLICATE  BRANCH IS REPORTED.
000150             THE FOLLOWING STATISTICS ARE REPORTED--
000160                 (1) TOTAL NUMBER OF POWER-NODE BRANCHES
000170                 (2) TOTAL NUMBER OF GROUND-NODE BRANCHES
000180                 (3) TOTAL NUMBER OF BRANCHES
000190                 (4) TOTAL NUMBER OF DUPLICATE POWER-NODE AND
000200                     GROUND-NODE BRANCHES.
000210 ENVIRONMENT DIVISION.
000220 CONFIGURATION SECTION.
000230 SOURCE-COMPUTER. IBM-360.
000240 OBJECT-COMPUTER. IBM-360.
000250 INPUT-OUTPUT SECTION.
000260 FILE-CONTROL.
000270     SELECT INPUT-TABLE  ASSIGN TO UT-S-FST.
000280     SELECT FINAL-SEGMENT-TABLE  ASSIGN TO UT-S-SORTOUT.
000290     SELECT REPORT-FILE  ASSIGN TO UT-S-RPT.
000300     SELECT XREF-TABLE   ASSIGN TO UT-S-XREF.
000310     SELECT BRANCH-TABLE ASSIGN TO UT-S-BRT.
000320     SELECT SORT-HOLD-AREA ASSIGN TO UT-S-SD1.
000330 DATA DIVISION.
000340 FILE SECTION.
000350 FD  INPUT-TABLE
000360             RECORDING MODE F
000370             LABEL RECORD OMITTED
000380         BLOCK 10 RECORDS
000390             DATA RECORD IN-TBL.
000400 01  IN-TBL.
000410     02  FROM-NODE   PICTURE 9(6).
000420     02  TO-NODE     PICTURE 9(6).
000430     02  SWITCH      PICTURE X.
000440     02  FILLER      PICTURE X(15).
000450     02  FROM-DATA   PICTURE X(16).
000460     02  TO-DATA     PICTURE X(16).
000470     02  BR-DIODE    PICTURE X.
000480     02  IMPEDANCE   PICTURE XXX.
000490     02  FILLER      PICTURE X(97).
000500     02  SECOND-WAY  PICTURE X.
000510 FD  FINAL-SEGMENT-TABLE
000520             RECORDING MODE F
000530             LABEL RECORD OMITTED
000540         BLOCK 20 RECORDS
000550             DATA RECORD FST.
000560 01  FST.
000570     02  FROM-NO     PICTURE 9(6).
000580     02  TO-NO       PICTURE X(6).
000590     02  SWITCH      PICTURE X.
000600     02  DATA-1      PICTURE X(47).
000610     02  DIODE       PICTURE X.
000620     02  IMPEDANCE   PICTURE XXX.
000630     02  DATA-2      PICTURE X(98).
000640 FD  XREF-TABLE
000650         RECORDING MODE F
000660         LABEL RECORD OMITTED
000670         BLOCK 5 RECORDS
000680         DATA RECORD XREF.
000690 01  XREF.
000700     02  BR-NO       PICTURE 9(6).
000710     02  FROM-NO     PICTURE 9(6).
000720     02  TO-NO       PICTURE X(6).
000730     02  SWITCH      PICTURE X.
000740     02  DATA-1      PICTURE X(47).
000750     02  DIODE       PICTURE X.
000760     02  IMPEDANCE   PICTURE XXX.
000770     02  DATA-2      PICTURE X(98).
000780 FD  REPORT-FILE
000790             RECORDING MODE F
000800             LABEL RECORD OMITTED
000810             DATA RECORD DELETED-RCD.
000820 01  DELETED-RCD     PICTURE X(132).
000830 FD  BRANCH-TABLE
000840             RECORDING MODE F
000850             LABEL RECORD OMITTED
000860             BLOCK 100 RECORDS
000870             DATA RECORD BRT.
000880 01  BRT.
000890     02  BR-NO       PICTURE 9(6).
000900     02  FROM-NO     PICTURE 9(6).
000910     02  TO-NO       PICTURE X(6).
000920     02  IMPEDANCE   PICTURE XXX.
000930     02  DIODE       PICTURE X.
000940     02  SWITCH      PICTURE X.
000950 SD  SORT-HOLD-AREA
000960             RECORDING MODE F
000970             DATA RECORD XAREA.
000980 01  XAREA.
000990     02  NODE-1      PICTURE X(6).
001000     02  NODE-2      PICTURE X(6).
001010     02  FILLER      PICTURE X(150).
001020 WORKING-STORAGE SECTION.
001030 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
001040 77  BRN             PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001050 77  NPWR            PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001060 77  NGND            PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001070 77  NDEL            PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001080 77  HOLD-TO-NODE    PICTURE X(6) VALUE ZERO.
001090 77  TO-NODE-HOLD    PICTURE 9(6).
001100 77  TO-DATA-HOLD    PICTURE X(16).
001110 01  WS-RECORD.
001120     02  FILLER      PICTURE X(15) VALUE 'RECORD DELETED '.
001130     02  FROM-NO     PICTURE 9(6).
001140     02  FILLER      PICTURE X VALUE SPACE.
001150     02  TO-NO       PICTURE X(6).
001160     02  FILLER      PICTURE X VALUE SPACE.
001170     02  DATA-1      PICTURE X(47).
001180     02  FILLER      PICTURE X(56) VALUE SPACES.
001190 PROCEDURE DIVISION.
001200     SORT SORT-HOLD-AREA ASCENDING KEY NODE-1 NODE-2
001210         INPUT PROCEDURE DELETE-REVERSE-RECORDS
001220         GIVING FINAL-SEGMENT-TABLE.
001230                             NOTE -------------------------------
001240                                 SORT DESCRIPTION - MAJOR FIELD
001250                             IS FROM-NODE NUMBER AND MINOR FIELD
001260                             IS TO-NODE NUMBER
001270                                 THE SORTED DATA SET WILL BE
001280                             ORDERED WITH POWER BRANCHES FIRST AND
001290                             GROUND BRANCHES SECOND FOLLOWED BY
001300                             ALL OTHER BRANCHES
001310                             -----------------------------------.
001320     OPEN INPUT FINAL-SEGMENT-TABLE.
001330     OPEN OUTPUT XREF-TABLE.
001340     OPEN OUTPUT BRANCH-TABLE.
001350     OPEN OUTPUT REPORT-FILE.
001360     DISPLAY 'EXEC STATISTICAL INFORMATION'.
001370 READ-FST.
001380     READ FINAL-SEGMENT-TABLE AT END GO TO JOBEND.
001390                             NOTE -------------------------------
001400                                 AFTER THE FINAL SEGMENT TABLE
001410                             IS SORTED, DUPLICATE POWER-NODE AND
001420                             GROUND-NODE BRANCHES ARE ELIMINATED
001430                                 POWER AND GROUND BRANCHES ARE
001440                             COUNTED FOR STATISTICAL DATA
001450                             -----------------------------------.
001460     IF FROM-NO IN FST = 1 OR = 2
001470         NEXT SENTENCE ELSE GO TO SKIP-NEXT-TEST.
001480     IF TO-NO IN FST = HOLD-TO-NODE GO TO REPORT-DUPLICATE-RCD.
001490     MOVE TO-NO IN FST TO HOLD-TO-NODE.
001500     IF FROM-NO IN FST = 1
001510         COMPUTE NPWR = NPWR + 1,
001520         GO TO SKIP-NEXT-TEST.
001530     IF FROM-NO IN FST = 2
001540         COMPUTE NGND = NGND + 1.
001550 SKIP-NEXT-TEST.
001560     COMPUTE BRN = BRN + 1.
001570                             NOTE -------------------------------
001580                                 A SEQUENTIAL BRANCH NUMBER IS
001590                             NOW ASSIGNED TO EACH BRANCH - THE
001600                             SEQUENCE STARTS WITH 1 AND INCREASES
001610                             BY 1 UNTIL ALL BRANCHES ARE
001620                             PROCESSED - DIODE AND IMPEDANCE
001630                             FIELDS ARE CHECKED FOR SPACES, ALL
001640                             SPACES ARE REPLACED BY ZEROS
001650                                 THE BRANCH IS THEN WRITTEN INTO
001660                             THE BRANCH TABLE DATA SET
001670                                 NOW, A BRANCH CROSS REFERENCE
001680                             RECORD IS CREATED FOR EACH BRANCH
001690                             TABLE RECORD - THE CROSS REFERENCE
001700                             DATA SET WILL BE USED IN THE PATH
001710                             REGENERATION PHASE
001720                             -----------------------------------.
001730     MOVE BRN TO BR-NO IN BRT.
001740     MOVE CORRESPONDING FST TO BRT.
001750     EXAMINE DIODE IN BRT REPLACING FIRST SPACE BY ZERO.
001760     EXAMINE IMPEDANCE IN BRT REPLACING ALL SPACES BY ZEROS.
001770     WRITE BRT.
001780     MOVE BRN TO BR-NO IN XREF.
001790     MOVE CORRESPONDING FST TO XREF.
001800     WRITE XREF.
001810     GO TO READ-FST.
001820 REPORT-DUPLICATE-RCD.
001830     MOVE CORRESPONDING FST TO WS-RECORD.
001840                             NOTE -------------------------------
001850                                 DUPLICATE POWER-NODE AND GROUND-
001860                             NODE BRANCHES ARE REPORTED AND
001870                             COUNTED HERE
001880                             -----------------------------------.
001890     WRITE DELETED-RCD FROM WS-RECORD.
001900     COMPUTE NDEL = NDEL + 1.
001910     GO TO READ-FST.
001920 JOBEND.
001930     CLOSE FINAL-SEGMENT-TABLE.
001940     CLOSE XREF-TABLE.
001950     CLOSE BRANCH-TABLE.
001960     CLOSE REPORT-FILE.
001970     DISPLAY 'POWER BRANCHES = ' NPWR.
001980     DISPLAY 'GROUND BRANCHES = ' NGND.
001990     DISPLAY 'DELETED BRANCHES = ' NDEL.
002000     DISPLAY 'TOTAL NO. BRANCHES = ' BRN.
002010     STOP RUN.
002020 DELETE-REVERSE-RECORDS SECTION.
002030     OPEN INPUT INPUT-TABLE.
002040                             NOTE -------------------------------
002050                                 THE FINAL SEGMENT TABLE HAS ALL
002060                             REVERSE RECORDS ELIMINATED
002070                                 IF A POWER OR GROUND NODE IS
002080                             FOUND ON THE TO-SIDE OF A BRANCH,
002090                             THE NODES OF THE BRANCH ARE REVERSED
002100                             SO ALL POWER AND GROUND NODES APPEAR
002110                             ON THE FROM-SIDE OF A BRANCH
002120                                 THE DIODE IS ALSO REVERSED IF
002130                             THIS SITUATION EXISTS - THE RECORD
002140                             IS THEN RELEASED TO THE SORT
002150                             -----------------------------------.
002160 READ-INPUT-TABLE.
002170     READ INPUT-TABLE AT END GO TO RTN.
002180     IF SECOND-WAY = '*' GO TO READ-INPUT-TABLE.
002190     IF TO-NODE = 1 OR = 2 NEXT SENTENCE ELSE GO TO RECORD-OK.
002200     MOVE TO-NODE TO TO-NODE-HOLD.
002210     MOVE FROM-NODE TO TO-NODE.
002220     MOVE TO-NODE-HOLD TO FROM-NODE.
002230     MOVE TO-DATA TO TO-DATA-HOLD.
002240     MOVE FROM-DATA TO TO-DATA.
002250     MOVE TO-DATA-HOLD TO FROM-DATA.
002260     IF BR-DIODE = '+' MOVE '-' TO BR-DIODE GO TO RECORD-OK.
002270     IF BR-DIODE = '-' MOVE '+' TO BR-DIODE.
002280 RECORD-OK.
002290     MOVE IN-TBL TO XAREA.
002300     RELEASE XAREA.
002310     GO TO READ-INPUT-TABLE.
002320 RTN.
002330     CLOSE INPUT-TABLE.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. NWREGN1.
000030 AUTHOR.     ALDEN R GUILLORY.
000040 INSTALLATION.   BOEING HOUSTON.
000050 DATE-WRITTEN.       FEBRUARY 8, 1969.
000060 REMARKS.        THIS IS  THE  BRANCH DELTA  PROGRAM  & REGENERATI
000070       ON-1, USING AS INPUT  THE BRANCH XREF TAPE GENERATED
000080             BY  THE BRANCH/CROSS REFERENCE TABLE PROGRAM
000090             (D2-118220-1) AND THE   PATH DEVIATION (D2-118221-1)
000100             TAPE (SORTED INTERNALLY ON BRANCH NUMBER)   AND
000110             OUTPUTS  THOSE  BRANCHES ON THE XREF TAPE NOT ON
000120             THE  PATH TAPE PLUS THE REGENED OUTPUT TAPE.
000130 ENVIRONMENT DIVISION.
000140 CONFIGURATION SECTION.
000150 SOURCE-COMPUTER.    IBM-360.
000160 OBJECT-COMPUTER.    IBM-360.
000170 INPUT-OUTPUT SECTION.
000180 FILE-CONTROL.
000190     SELECT INPT-P    ASSIGN TO UT-S-IPP.
000200     SELECT INPT-X    ASSIGN TO UT-S-IPX.
000210     SELECT OUTFILE   ASSIGN TO UT-S-OUTF.
000220 DATA DIVISION.
000230 FILE SECTION.
000240 FD  INPT-P
000250     RECORDING MODE IS F
000260     LABEL RECORDS ARE OMITTED
000270     BLOCK CONTAINS 100 RECORDS
000280     DATA RECORD IS IN-P.
000290 01  IN-P.
000300     02  FILLER  PICTURE X(18).
000310 FD  INPT-X
000320     RECORDING MODE IS F
000330     LABEL RECORDS ARE OMITTED
000340     BLOCK CONTAINS  5 RECORDS
000350     DATA RECORD IS IN-X.
000360 01  IN-X.
000370     02  FILLER  PICTURE X(168).
000380 FD  OUTFILE
000390     RECORDING MODE IS F
000400     BLOCK CONTAINS 10 RECORDS
000410     LABEL RECORDS ARE OMITTED
000420     DATA RECORD IS TAPE-OUT.
000430 01  TAPE-OUT.
000440     02  FILLER  PICTURE X(180).
000450 WORKING-STORAGE SECTION.
000460 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000470 77  X-REF-END   PICTURE X(3) VALUE SPACE.
000480 01  PTH-BR-F.
000490     02  PTH-P   PICTURE X(6)  VALUE SPACE.
000500     02  EL-P    PICTURE X(6)  VALUE SPACE.
000510     02  BR-P    PICTURE X(6)  VALUE SPACE.
000520 01  X-REF.
000530     02  X-BR    PICTURE X(6)  VALUE SPACE.
000540     02  X-F     PICTURE X(6)  VALUE SPACE.
000550     02  X-T     PICTURE X(6)  VALUE SPACE.
000560     02  X-S     PICTURE X(1)  VALUE SPACE.
000570     02  X-D     PICTURE X(149) VALUE SPACE.
000580 01  WS-O.
000590     02  PTH-O   PICTURE X(6)    VALUE SPACE.
000600     02  EL-O    PICTURE X(6)    VALUE SPACE.
000610     02  BR-O    PICTURE X(6)    VALUE SPACE.
000620     02  F-O     PICTURE X(6)    VALUE SPACE.
000630     02  T-O     PICTURE X(6)    VALUE SPACE.
000640     02  S-O     PICTURE X(1)    VALUE SPACE.
000650     02  D-O     PICTURE X(149)  VALUE SPACE.
000660 PROCEDURE DIVISION.
000670     OPEN INPUT INPT-P.
000680     OPEN INPUT INPT-X.
000690     OPEN OUTPUT OUTFILE.
000700 READ-PTH-BR-F.
000710     READ    INPT-P  INTO    PTH-BR-F    AT  END
000720                             GO  TO  THE-END.
000730                             NOTE -------------------------------
000740                             THIS TAPE MUST BE SORTED IN
000750                             BRANCH NUMBER SEQUENCE
000760                             -----------------------------------.
000770 MATCH-BR-NO.
000780     IF BR-P < X-BR
000790         DISPLAY ' X-REF TABLE DOES NOT CONTAIN BRANCH ' BR-P
000800         GO TO READ-PTH-BR-F.
000810     IF BR-P = X-BR       GO TO BR-NO-EQUAL.
000820     READ INPT-X INTO  X-REF  AT END MOVE 'YES' TO X-REF-END
000830         DISPLAY 'X-REF TABLE DOES NOT CONTAIN BRANCH ' BR-P
000840         GO TO THE-END.
000850                             NOTE -------------------------------
000860                             THIS TAPE MUST BE SORTED IN
000870                             BRANCH NUMBER SEQUENCE
000880                             -----------------------------------.
000890     GO TO MATCH-BR-NO.
000900 BR-NO-EQUAL.
000910     MOVE  PTH-P  TO PTH-O.
000920     MOVE  EL-P   TO EL-O.
000930     MOVE  BR-P   TO BR-O.
000940     MOVE  X-F    TO F-O.
000950     MOVE  X-T    TO T-O.
000960     MOVE  X-S    TO S-O.
000970     MOVE  X-D    TO D-O.
000980     WRITE TAPE-OUT FROM WS-O.
000990     MOVE SPACES TO PTH-BR-F  WS-O.
001000     GO TO READ-PTH-BR-F.
001010 THE-END.
001020     IF X-REF-END = 'YES' DISPLAY 'PREMATURE END ON X-REF '.
001030     CLOSE INPT-P.
001040     CLOSE INPT-X.
001050     CLOSE OUTFILE.
001060     DISPLAY 'END OF RUN'.
001070     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. 'PTHSW'.
000030 AUTHOR. A GUILLORY.
000040 DATE-WRITTEN. OCTOBER 15, 1968.
000050 REMARKS.  THIS PROGRAM HAS 3 FUNCTIONS,  THEY ARE
000060     1.  GENERATION OF THE OUTPUT TAPE SORTED ON  BRANCH
000070         NUMBER  FOR THE COMMON REVERSE CURRENT BRANCH REPORT
000080         THE TAPE GENERATED HAS 2 TYPES OF SWITCH CONDITIONS
000090         1.  IN  CHARACTER NUMBER 181 A PATH EITHER HAS  S   OR
000100             BLANK INDICATING WEITHER OR NOT IT IS A SWITCH PATH
000110         2.  IN  CHARACTER NUMBER 180 AN ELEMENT CONTAINS EITHER
000120             A.  S  =    SWITCH BRANCH
000130                 1.  NORMAL SWITCH  S(ALPHA NUMERIC  OTHER THAN K,
000140                                  OR  I)
000150                 2.  CIRCUIT  BREAKER
000160                 3.  UMBILICAL DISCONNECT
000170                 ITEMS  1  AND  2  ARE  ASSIGNED IN THE INITIAL
000180                         SEGMENT TABLE PROGRAM
000190                 ITEM  3  IS DONE IN THIS PROGRAM
000200             B.  N  =    SPECIAL NODES  (K OR I ITEMS)
000210             C.  B  =     SWITCHS AND SPECIAL NODES (SK OR SI)
000220             D.  T  =    POWER / GROUND / DUMMY GROUNDS
000230     2.  GENERATION OF THE REVERSE CURRENT BRANCH REPORT.
000240     3.  GENERATION OF THE POWER TO POWER PATHS CROSS REFERENCE
000250                  TABLE.
000260 ENVIRONMENT DIVISION.
000270 CONFIGURATION SECTION.
000280 SOURCE-COMPUTER. IBM-360.
000290 OBJECT-COMPUTER. IBM-360.
000300 INPUT-OUTPUT SECTION.
000310 FILE-CONTROL.
000320     SELECT PATH-IN  ASSIGN  TO  UT-S-PTHIN.
000330     SELECT DISK-1   ASSIGN  TO  UT-S-DSKIO.
000340     SELECT  SRTD-FLE   ASSIGN  TO  UT-S-SORTOUT.
000350     SELECT INLINE   ASSIGN  TO  UT-S-INLDI.
000360     SELECT SRT-FLE ASSIGN TO UT-S-SD1.
000370 DATA DIVISION.
000380 FILE SECTION.
000390 FD  SRTD-FLE
000400     LABEL  RECORDS  ARE  OMITTED
000410     RECORDING  MODE  IS  F
000420     BLOCK  CONTAINS   10  RECORDS
000430     DATA  RECORD  IS  SRTD-REC.
000440 01  SRTD-REC            PICTURE X(181).
000450 FD  PATH-IN
000460     RECORDING MODE IS F
000470     BLOCK CONTAINS 10 RECORDS
000480     LABEL RECORDS ARE OMITTED
000490     DATA RECORD IS  PTHSIN.
000500 01  PTHSIN              PICTURE X(181).
000510 FD  DISK-1
000520     RECORDING MODE IS F
000530     BLOCK  CONTAINS    10  RECORDS
000540     LABEL RECORDS ARE OMITTED
000550     DATA RECORD IS  DISKEE.
000560 01  DISKEE              PICTURE X(132).
000570 FD  INLINE
000580     RECORDING   MODE  IS F
000590     LABEL RECORDS ARE OMITTED
000600     DATA RECORD IS INCD.
000610 01  INCD.
000620  02 FRST                PICTURE X(23).
000630  02 FILLER              PICTURE X(57).
000640 SD  SRT-FLE
000650     RECORDING  MODE  IS  F
000660     DATA  RECORD  IS   SRT-REC.
000670 01  SRT-REC.
000680     02  PATH-NUMBER     PICTURE 9(6).
000690     02  FILLER          PICTURE 9(6).
000700     02  BRANCH-NO       PICTURE 9(6).
000710     02  FILLER          PICTURE X(163).
000720 WORKING-STORAGE SECTION.
000730 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000740 77  I                   PICTURE 9(6)  VALUE ZERO.
000750 77  J                   PICTURE 9(6)  VALUE ZERO.
000760 77  K                   PICTURE 9(6)  VALUE ZERO.
000770 77  DEL-UNIQUE          PICTURE 9(6) VALUE ZERO.
000780 77  DEL-SW              PICTURE 9(6) VALUE ZERO.
000790 77  DEL-DIR             PICTURE 9(6) VALUE ZERO.
000800 77  TOT-BRA-SET         PICTURE 9(6) VALUE ZERO.
000810 77  SWITCH-PATHS        PICTURE 9(6) VALUE ZERO.
000820 77  NON-SWITCH-PATHS    PICTURE 9(6) VALUE ZERO.
000830 77  LIN-CT              PICTURE 99 VALUE ZERO.
000840 77  PG-CTT              PICTURE 9(4) VALUE ZERO.
000850 77  LEG-PTH             PICTURE 9     VALUE ZERO.
000860 77  ALL-PTH             PICTURE 9     VALUE ZERO.
000870 77  NON-SW              PICTURE X  VALUE SPACES.
000880 01  GROUP1.
000890     02  ARRAY1  OCCURS  100  TIMES.
000900         03  PTH-TYPE                    PICTURE X.
000910         03  PT-A                        PICTURE 9(6).
000920         03  EL-A                        PICTURE 9(6).
000930         03  BR-A                        PICTURE 9(6).
000940         03  FRNA                        PICTURE 9(6).
000950         03  TO-A                        PICTURE 9(6).
000960         03  SW-A                        PICTURE X.
000970         03  BRD-A                       PICTURE X(15).
000980         03  FR-A.
000990             04  FR-SWIT-A.
001000                 05  FR-INL-A.
001010                     06  FILLER          PICTURE XX.
001020                     06  CB-SK-SI.
001030                         07  P-TYP-A     PICTURE X.
001040                         07  FILLER      PICTURE X.
001050                     06  FILLER          PICTURE X(7).
001060                 05  FILLER              PICTURE X.
001070             04  FILLER                  PICTURE X(4).
001080         03  TO-TRM-A.
001090             04  TO-SWIT-A               PICTURE X(12).
001100             04  FILLER                  PICTURE X(4).
001110         03  AL-DAT-A                    PICTURE X(102).
001120 01  ALT-HOLD.
001130     02  PATHN           PICTURE 9(6).
001140     02  ELEMN           PICTURE 9(6).
001150     02  BRANN           PICTURE 9(6).
001160     02  FROMN           PICTURE 9(6).
001170     02  TONUMB          PICTURE 9(6).
001180     02  BOX-R           PICTURE X(15).
001190     02  FROM-C          PICTURE X(16).
001200     02  TO-C            PICTURE X(16).
001210     02  DDATA           PICTURE X(102).
001220     02  SW-CT           PICTURE X.
001230     02  SREC-181        PICTURE X.
001240 01  GRP2.
001250  02 ARA     OCCURS  200 TIMES.
001260     03  TO-INLA         PICTURE X(11).
001270     03  FR-INLA         PICTURE X(11).
001280     03  UMBIL           PICTURE X.
001290 01  GROUP2.
001300     02  ARRAY2 OCCURS 400 TIMES.
001310         03  PT-A2       PICTURE 9(6).
001320         03  EL-A2       PICTURE 9(6).
001330         03  BR-A2       PICTURE 9(6).
001340         03  BOX-A2      PICTURE X(15).
001350         03  FROM-A2.
001360             04 FR-C-A2  PICTURE X(8).
001370             04 FR-B-A2  PICTURE X(4).
001380             04 FR-P-A2  PICTURE X(4).
001390         03  TO-A2.
001400             04 TO-C-A2  PICTURE X(8).
001410             04 TO-B-A2  PICTURE X(4).
001420             04 TO-P-A2  PICTURE X(4).
001430         03  SWIT-A2     PICTURE X.
001440         03  DIRECT-A2   PICTURE X.
001450 01  DDATA-HLD.
001460     02  FILLER          PICTURE X(4).
001470     02  SPEC-HLD.
001480         03  FILLER      PICTURE X(7).
001490         03  REST-1      PICTURE X(8).
001500     02  FILLER          PICTURE X(83).
001510 01  PATH-H.
001520  02 FILLER              PICTURE X.
001530  02 PT-N-H              PICTURE 9(6).
001540  02 FILLER              PICTURE X(174).
001550 01  HEAD-1.
001560     02 FILLER   PICTURE X(10) VALUE SPACES.
001570     02 FILLER   PICTURE X(30) VALUE
001580                 'POWER TO POWER CROSS REFERENCE'.
001590 01  HEAD-2.
001600     02 FILLER   PICTURE X(10) VALUE SPACES.
001610     02  FILLER  PICTURE X(11) VALUE 'PATH NUMBER'.
001620 01  HEAD-3.
001630     02 FILLER   PICTURE X(10) VALUE SPACES.
001640     02  P-P-P-N PICTURE 9(6).
001650 01  HD-0.
001660     02  FILLER  PICTURE X(132)  VALUE SPACES.
001670 01  HD-1.
001680     02  FILLER  PICTURE X(23)   VALUE SPACES.
001690     02  FILLER  PICTURE X(21)   VALUE 'ASP OUTPUT   REVERSE-'.
001700     02  FILLER  PICTURE X(21)   VALUE 'CURRENT BRANCH REPORT'.
001710     02  FILLER  PICTURE X(4)    VALUE SPACES.
001720     02  FILLER  PICTURE X(5)    VALUE 'DATE '.
001730     02  PRT-DA  PICTURE X(8).
001740     02  FILLER  PICTURE X(4)    VALUE SPACES.
001750     02  FILLER  PICTURE X(13)   VALUE 'SPACECRAFT   '.
001760     02  SP-CRT  PICTURE X(20).
001770 01  HD-2.
001780     02  FILLER  PICTURE X(7)  VALUE SPACES.
001790     02  FILLER  PICTURE X(4)   VALUE 'PAGE'.
001800     02  FILLER  PICTURE X     VALUE SPACES.
001810     02  PG-CT   PICTURE ZZZ9.
001820     02  FILLER  PICTURE X(40) VALUE SPACES.
001830     02  FILLER  PICTURE X(20)   VALUE 'BRANCH CONTAINED IN '.
001840 01  HD-3.
001850     02  FILLER  PICTURE X(7) VALUE SPACES.
001860     02  FILLER  PICTURE X(3) VALUE 'OF '.
001870     02  FILLER  PICTURE X(15)   VALUE 'BRANCH NUMBER  '.
001880     02  PR-BRA  PICTURE 9(6).
001890     02  FILLER  PICTURE X(6)  VALUE SPACES.
001900     02  FILLER  PICTURE X(12) VALUE 'AREA HARNESS'.
001910     02  FILLER  PICTURE X(7)  VALUE SPACES.
001920     02  FILLER  PICTURE X(19)   VALUE '  PATH   *  ELEMENT'.
001930     02  FILLER  PICTURE X(23)   VALUE '  *  DIRECTION  *  SWIT'.
001940     02  FILLER  PICTURE X(07)   VALUE 'CHED  *'.
001950 01  HD-4.
001960     02  FILLER  PICTURE X(15) VALUE SPACES.
001970     02  FILLER  PICTURE X(22) VALUE 'BAY  ITEM     PIN     '.
001980     02  FILLER  PICTURE X(18) VALUE 'BOX REF DES       '.
001990     02  FILLER  PICTURE X(50)   VALUE ALL '*'.
002000 01  HD-5.
002010     02  FILLER  PICTURE X(65)   VALUE SPACES.
002020     02  FILLER  PICTURE X       VALUE '*'.
002030     02  FILLER  PICTURE X(11)   VALUE SPACES.
002040     02  FILLER  PICTURE X       VALUE '*'.
002050     02  FILLER  PICTURE X(13)   VALUE SPACES.
002060     02  FILLER  PICTURE X       VALUE '*'.
002070     02  FILLER  PICTURE X(12)   VALUE SPACES.
002080     02  FILLER  PICTURE X       VALUE '*'.
002090 01  HD-6.
002100     02  FILLER  PICTURE X(7)  VALUE SPACES.
002110     02  FILLER  PICTURE X(5)    VALUE 'FROM '.
002120     02  FILLER  PICTURE X(3)  VALUE SPACES.
002130     02  PRT-FB  PICTURE X(4).
002140     02  FILLER  PICTURE X     VALUE SPACES.
002150     02  PRT-FR  PICTURE X(8).
002160     02  FILLER  PICTURE X     VALUE SPACES.
002170     02  PRT-FP  PICTURE X(4).
002180     02  FILLER  PICTURE X(4)  VALUE SPACES.
002190     02  PRT-BX  PICTURE X(15).
002200     02  FILLER  PICTURE X(5)    VALUE SPACES.
002210     02  PTH-1   PICTURE 9(6).
002220     02  FILLER  PICTURE X(6)    VALUE '  *   '.
002230     02  ELM-1   PICTURE 9(6).
002240     02  FILLER  PICTURE X(9)    VALUE '  *      '.
002250     02  DIR-1   PICTURE X.
002260     02  FILLER  PICTURE X(12)   VALUE '      *     '.
002270     02  SWT-1   PICTURE X.
002280     02  FILLER  PICTURE X(7)    VALUE '      *'.
002290 01  HD-7.
002300     02  FILLER  PICTURE X(8)  VALUE SPACES.
002310     02  FILLER  PICTURE X(4)    VALUE 'TO  '.
002320     02  FILLER  PICTURE X(3)  VALUE SPACES.
002330     02  PRT-TB  PICTURE X(4).
002340     02  FILLER  PICTURE X     VALUE SPACES.
002350     02  PRT-TO  PICTURE X(8).
002360     02  FILLER  PICTURE X     VALUE SPACES.
002370     02  PRT-TP  PICTURE X(4).
002380     02  FILLER  PICTURE X(24) VALUE SPACES.
002390     02  PTH-2   PICTURE 9(6).
002400     02  FILLER  PICTURE X(6)    VALUE '  *   '.
002410     02  ELM-2   PICTURE 9(6).
002420     02  FILLER  PICTURE X(9)    VALUE '  *      '.
002430     02  DIR-2   PICTURE X.
002440     02  FILLER  PICTURE X(12)   VALUE '      *     '.
002450     02  SWT-2   PICTURE X.
002460     02  FILLER  PICTURE X(7)    VALUE '      *'.
002470 01  HD-8.
002480     02  FILLER  PICTURE X(57)   VALUE SPACES.
002490     02  PTH-3   PICTURE 9(6).
002500     02  FILLER  PICTURE X(6)    VALUE '  *   '.
002510     02  ELM-3   PICTURE 9(6).
002520     02  FILLER  PICTURE X(9)    VALUE '  *      '.
002530     02  DIR-3   PICTURE X.
002540     02  FILLER  PICTURE X(12)   VALUE '      *     '.
002550     02  SWT-3   PICTURE X.
002560     02  FILLER  PICTURE X(7)    VALUE '      *'.
002570 01  HD-9.
002580     02  FILLER  PICTURE X(55) VALUE SPACES.
002590     02  FILLER  PICTURE X(50) VALUE ALL '*'.
002600 01  FOOT-1.
002610     02  FILLER  PICTURE X(10)   VALUE SPACES.
002620     02  FILLER  PICTURE X(7)    VALUE 'ANALYST'.
002630     02  FILLER  PICTURE X     VALUE SPACES.
002640     02  FILLER  PICTURE X(33) VALUE ALL '-'.
002650     02  FILLER  PICTURE X(10)   VALUE SPACES.
002660     02  FILLER  PICTURE X(6)    VALUE 'DATE  '.
002670     02  FILLER  PICTURE X(12) VALUE ALL '-'.
002680     02  FILLER  PICTURE X(8)    VALUE SPACES.
002690     02  FILLER  PICTURE X(10)   VALUE 'MANHOURS  '.
002700     02  FILLER  PICTURE X(20) VALUE ALL '-'.
002710 01  FOOT-2.
002720     02  FILLER  PICTURE X(10)   VALUE SPACES.
002730     02  FILLER  PICTURE X(8)    VALUE 'COMMENTS'.
002740 01  DATE-SC-CD.
002750     02  DA-MO-YR        PICTURE X(8).
002760     02  FILLER          PICTURE X(2).
002770     02  CUR-SC          PICTURE X(20).
002780     02  FILLER          PICTURE X(50).
002790 PROCEDURE DIVISION.
002800     MOVE  1  TO  J.
002810     MOVE 1  TO  I.
002820     OPEN INPUT  INLINE.
002830     OPEN INPUT  PATH-IN.
002840     OPEN OUTPUT DISK-1.
002850     MOVE  50  TO  LIN-CT.
002860     READ INLINE  AT  END  GO  TO  RD1.
002870         MOVE  INCD  TO  DATE-SC-CD.
002880         MOVE  DA-MO-YR  TO  PRT-DA.
002890         MOVE CUR-SC  TO  SP-CRT.
002900 RD1.
002910     READ INLINE  AT END MOVE 0 TO I  GO TO INPUT-1.
002920     MOVE    FRST    TO  ARA (I).
002930     ADD   1   TO  I.
002940     IF    I    >        200     GO TO   CLOSE-UP.
002950     GO  TO  RD1.
002960 INPUT-1.
002970     SORT  SRT-FLE  ASCENDING KEY  BRANCH-NO  PATH-NUMBER
002980         INPUT PROCEDURE PTH-SW-P  THRU  PTH-SW-EXIT
002990         GIVING  SRTD-FLE.
003000         GO  TO  BRANCH-REPORT.
003010 PTH-SW-P SECTION.
003020 RD2.
003030     IF  ALL-PTH  =  5  MOVE  0  TO  ALL-PTH
003040         GO  TO  PTH-SW-EXIT.
003050     READ PATH-IN INTO PATH-H AT END MOVE 5 TO ALL-PTH
003060         GO TO PROC-DSK.
003070     IF  I  =  0  MOVE  1  TO  I
003080         GO TO SK-IT.
003090     IF PT-N-H  =  PT-A  IN  ARRAY1 (I) NEXT SENTENCE ELSE
003100         GO TO PROC-DSK.
003110     ADD  1  TO  I.
003120     IF    I   >    100
003130         DISPLAY  '  LOST PATH  DUE  TO  ARRAY1 SIZE  '
003140         DISPLAY  '  ENLARGE  ARRAY1   SIZE  '
003150         MOVE  2  TO  FRNA (100)
003160         MOVE '  DUMMY GND     '  TO  FR-A (100)
003170         GO  TO  RD2.
003180 SK-IT.
003190     MOVE  PATH-H  TO  ARRAY1 (I).
003200         GO  TO  RD2.
003210 PROC-DSK.
003220     MOVE  1  TO  K.
003230     MOVE  2  TO  J.
003240     IF PTH-TYPE (1)  =  '1'   PERFORM XREF-CK.
003250     MOVE  'T'  TO  SW-A (1).
003260     PERFORM SW-CK  THRU  SW-CK-EX.
003270 WRITE-PATH.
003280     MOVE  1  TO  J.
003290 LOOP-4.
003300     PERFORM   ARA-MV.
003310     MOVE  ALT-HOLD  TO  SRT-REC.
003320     RELEASE  SRT-REC.
003330     ADD  1  TO  J.
003340     IF  J  >  I  NEXT  SENTENCE  ELSE
003350         GO  TO  LOOP-4.
003360     IF NON-SW  =  'S'       ADD  1  TO  SWITCH-PATHS  ELSE
003370           ADD  1  TO  NON-SWITCH-PATHS.
003380         MOVE  SPACES  TO  NON-SW.
003390         MOVE  1  TO  I.
003400         MOVE  1  TO  J.
003410         MOVE  PATH-H   TO  ARRAY1 (1).
003420         GO  TO  RD2.
003430 PTH-SW-EXIT.
003440     EXIT.
003450 BRANCH-REPORT SECTION.
003460     OPEN  INPUT SRTD-FLE.
003470     MOVE  0  TO  I.
003480     MOVE   0  TO  LIN-CT.
003490     WRITE  DISKEE  FROM  HD-0  AFTER  POSITIONING 0.
003500 RD3.
003510     IF  ALL-PTH  =  5  GO  TO  CLOSE-UP.
003520     READ SRTD-FLE  INTO  ALT-HOLD  AT  END
003530         MOVE  5  TO  ALL-PTH     GO TO  PROC-BRANCH.
003540     NOTE -------1------------------------------------------------
003550         NO  POWERS OR GROUNDS ARE CONSIDERED IN REVERSE CURRENT
003560         REPORT
003570     ---------------------.
003580                 IF  BRANN  =   0
003590                       GO  TO  RD3.
003600                 IF  FROMN  =  1  OR  =  2
003610                       GO  TO  RD3.
003620                 IF  TONUMB  =  1  OR  =  2
003630                       GO  TO  RD3.
003640     IF  I  =  0  MOVE  1  TO  I
003650         PERFORM  MV-TO-ARA2
003660         GO  TO  RD3.
003670     IF  BRANN  =  BR-A2 (I)  NEXT  SENTENCE  ELSE
003680         GO  TO  PROC-BRANCH.
003690     ADD  1  TO  I.
003700     IF  I  >  400
003710         COMPUTE  I  =  I  -  1
003720     DISPLAY  ' BRANCH COMMON TO GREATER THAN 400 PATHS ' BRANN
003730         GO  TO  PROC-BRANCH.
003740     PERFORM  MV-TO-ARA2.
003750     GO  TO  RD3.
003760 MV-TO-ARA2.
003770     MOVE  PATHN         TO      PT-A2 (I).
003780     MOVE  ELEMN         TO      EL-A2 (I).
003790     MOVE  BRANN         TO      BR-A2 (I).
003800     MOVE  FROM-C        TO      FROM-A2 (I).
003810     MOVE  TO-C          TO      TO-A2 (I).
003820     MOVE  SREC-181      TO      SWIT-A2 (I).
003830     IF  BOX-R  =  SPACES
003840         MOVE  DDATA   TO  DDATA-HLD
003850         MOVE  SPACES  TO  BOX-A2 (I)
003860         MOVE  SPACES  TO  REST-1
003870         MOVE  SPEC-HLD  TO  BOX-A2 (I)
003880             ELSE
003890         MOVE  BOX-R   TO  BOX-A2 (I).
003900 MV-TO-EX.
003910     EXIT.
003920 PROC-BRANCH.
003930     ADD  1  TO  TOT-BRA-SET.
003940     MOVE  1  TO  J.
003950     MOVE  2  TO  K.
003960     IF  J  =  I
003970         MOVE  1  TO  I
003980     ADD  1  TO  DEL-UNIQUE
003990         PERFORM  MV-TO-ARA2
004000         GO  TO  RD3.
004010     NOTE -------2------------------------------------------------
004020         AT LEAST  1  BRANCH (PATH)  MUST BE SWITCHED IN ORDER
004030         TO BE CONSIDERED
004040     --------------------------.
004050 CK-SWITCHS.
004060     IF  SWIT-A2 (J)  =  'S'
004070         MOVE  1  TO  J
004080         GO  TO  CK-DIRECTION.
004090     ADD  1  TO  J.
004100     IF  J  >  I
004110         MOVE  1  TO  J
004120         MOVE  1  TO  I
004130     ADD  1  TO  DEL-SW
004140         PERFORM  MV-TO-ARA2
004150         GO  TO  RD3.
004160     GO  TO  CK-SWITCHS.
004170     NOTE -------3------------------------------------------------
004180         THE FIRST BRANCH IS GIVEN A  +  DIRECTION  AND
004190         EVERY OTHER BRANCH IN THE SET IS TESTED AGAINST THE
004200         FIRST ON FROM NODE ---  IF A DISCREPANCY EXIST
004210         THAT BRANCH IS GIVEN A  -  DIRECTION -- THER MUST EXIST A
004220         DISCREPANCY IN ORDER TO REPORT THE SET
004230     ------------------------------------------------.
004240 CK-DIRECTION.
004250     MOVE  '+' TO  DIRECT-A2 (1).
004260     MOVE  1  TO  LEG-PTH.
004270 CK-DIR-LOP.
004280     IF  FROM-A2 (J)  =  FROM-A2 (K)
004290         MOVE  '+'  TO  DIRECT-A2 (K)
004300         GO  TO  ADD-TO-K.
004310     MOVE  0  TO  LEG-PTH.
004320     MOVE  '-'  TO  DIRECT-A2 (K).
004330 ADD-TO-K.
004340     ADD  1  TO  K.
004350     IF  K  >  I  NEXT  SENTENCE  ELSE
004360         GO  TO  CK-DIR-LOP.
004370     IF  LEG-PTH  =  1
004380         MOVE   1  TO  I, J, K
004390     ADD  1  TO  DEL-DIR
004400         PERFORM  MV-TO-ARA2
004410         GO  TO  RD3.
004420     MOVE  2  TO  K.
004430     MOVE  BR-A2 (J)  TO  PR-BRA.
004440     MOVE  1  TO  PG-CTT.
004450 REPORT-BRANCH.
004460     IF  PG-CTT  =   1
004470         NEXT  SENTENCE  ELSE
004490         WRITE DISKEE  FROM  HD-9  AFTER  POSITIONING 1.
004480         WRITE DISKEE  FROM  HD-5  AFTER  POSITIONING 1.
004500     MOVE  PT-A2 (J)    TO  PTH-1.
004510     MOVE  EL-A2 (J)    TO  ELM-1.
004520     MOVE  DIRECT-A2 (J)  TO  DIR-1.
004530     MOVE  SWIT-A2 (J)  TO  SWT-1.
004540     MOVE    FR-C-A2 (J)  TO PRT-FR.
004550     MOVE    FR-B-A2 (J)  TO PRT-FB.
004560     MOVE    FR-P-A2 (J)  TO PRT-FP.
004570     MOVE  BOX-A2 (J)   TO  PRT-BX.
004580     MOVE    TO-C-A2 (J)  TO PRT-TO.
004590     MOVE    TO-B-A2 (J)  TO PRT-TB.
004600     MOVE    TO-P-A2 (J)  TO PRT-TP.
004610     MOVE  PT-A2 (K)    TO  PTH-2.
004620     MOVE  EL-A2 (K)    TO  ELM-2.
004630     MOVE  DIRECT-A2 (K)  TO  DIR-2.
004640     MOVE  SWIT-A2 (K)  TO  SWT-2.
004650     MOVE  PG-CTT  TO  PG-CT.
004660     WRITE  DISKEE  FROM  HD-0  AFTER  POSITIONING 0.
004670     WRITE  DISKEE  FROM  HD-1  AFTER  POSITIONING 3.
004680     WRITE  DISKEE  FROM  HD-2  AFTER  POSITIONING 2.
004690     WRITE  DISKEE  FROM  HD-3  AFTER  POSITIONING 2.
004700     WRITE  DISKEE  FROM  HD-4  AFTER  POSITIONING 1.
004710     WRITE  DISKEE  FROM  HD-5  AFTER  POSITIONING 1.
004720     WRITE  DISKEE  FROM  HD-6  AFTER  POSITIONING 1.
004730     WRITE  DISKEE  FROM  HD-7  AFTER  POSITIONING 1.
004740     MOVE  11  TO  LIN-CT.
004750 HEADER-DONE.
004760     ADD  1  TO  K.
004770     IF  K  >  I
004780         GO  TO  WRITE-FOOT.
004790     MOVE  PT-A2 (K)  TO  PTH-3.
004800     MOVE  EL-A2 (K)  TO  ELM-3.
004810     MOVE  DIRECT-A2 (K)  TO  DIR-3.
004820     MOVE  SWIT-A2 (K)  TO  SWT-3.
004830     WRITE  DISKEE  FROM    HD-8  AFTER  POSITIONING 1.
004840     ADD  1  TO  LIN-CT.
004850     IF  LIN-CT  >  40
004860         COMPUTE J  =  K  +  1
004870         COMPUTE K  =  K  +  1
004880         GO  TO  WRITE-FOOT.
004890     GO  TO  HEADER-DONE.
004900 WRITE-FOOT.
004910     ADD  1  TO  PG-CTT.
004920     IF  ALL-PTH  =  5
004930         GO  TO  WRT-LST.
004940     IF  K  >  I
004950         NEXT  SENTENCE  ELSE   GO  TO  REPORT-BRANCH.
004960 WRT-LST.
004970     WRITE  DISKEE  FROM  HD-5  AFTER  POSITIONING 1.
004980     WRITE   DISKEE  FROM HD-9   AFTER POSITIONING 1.
004990     WRITE  DISKEE  FROM  HD-0  AFTER  POSITIONING 3.
005000     WRITE  DISKEE  FROM  FOOT-1  AFTER  POSITIONING 3.
005010     WRITE  DISKEE  FROM  HD-0  AFTER POSITIONING 3.
005020     WRITE  DISKEE  FROM  HD-0  AFTER POSITIONING 3.
005030     WRITE  DISKEE  FROM  FOOT-2  AFTER  POSITIONING 2.
005040     MOVE  1  TO  I, J, K.
005050     PERFORM  MV-TO-ARA2.
005060     GO  TO  RD3.
005070 ARA-MV.
005080     MOVE  PT-A (J)      TO  PATHN.
005090     MOVE  EL-A (J)      TO ELEMN.
005100     MOVE  BR-A (J)  TO  BRANN.
005110     MOVE  FRNA (J)      TO  FROMN.
005120     MOVE  TO-A (J)  TO  TONUMB.
005130     MOVE  BRD-A (J)     TO  BOX-R.
005140     MOVE  FR-A (J)      TO  FROM-C.
005150     MOVE  TO-TRM-A (J)  TO  TO-C.
005160     MOVE  AL-DAT-A (J)  TO  DDATA.
005170     MOVE  SW-A (J)  TO  SW-CT.
005180     MOVE  NON-SW  TO  SREC-181.
005190 SW-CK.
005200     IF  FR-SWIT-A (J)  =  TO-SWIT-A (J)   NEXT SENTENCE ELSE
005210         GO  TO  CK-SKSI.
005220     IF  CB-SK-SI (J)  =  'SK'  OR  =  'SI'
005230         MOVE  'B'  TO  SW-A (J)
005240         MOVE  'S'  TO  NON-SW
005250         GO  TO  ADD-TO-J.
005260     IF  CB-SK-SI (J) = 'CB'
005270         MOVE 'S' TO SW-A (J)
005280         MOVE  'S'  TO  NON-SW
005290         GO  TO  ADD-TO-J.
005300     IF   P-TYP-A (J)  =  'S'
005310         MOVE  'S' TO  SW-A (J)
005320         MOVE  'S'  TO  NON-SW
005330         GO  TO  ADD-TO-J.
005340     IF  P-TYP-A (J)  =  'P'  OR  =  'J'
005350         MOVE  1  TO  K
005360         PERFORM INLINE-DISC  THRU  INLINE-EX
005370         GO  TO  ADD-TO-J.
005380     IF  P-TYP-A (J)  =  'K'  OR  =  'I'
005390         MOVE  'N'  TO  SW-A (J)
005400         GO  TO  ADD-TO-J.
005410     MOVE  SPACES  TO  SW-A (J).
005420     GO  TO  ADD-TO-J.
005430 CK-SKSI.
005440     IF  CB-SK-SI  (J)  =  'SK'  OR  =  'SI'
005450         NEXT  SENTENCE  ELSE
005460         GO  TO  CK-KI-UMB.
005470     MOVE  'N'  TO  SW-A (J).
005480     GO  TO  ADD-TO-J.
005490 CK-KI-UMB.
005500     IF  P-TYP-A (J)  =  'K'  OR  =  'I'
005510         NEXT  SENTENCE  ELSE
005520         GO  TO  INLINE-CK.
005530     MOVE  'N'  TO  SW-A (J).
005540     GO  TO  ADD-TO-J.
005550 INLINE-CK.
005560     IF  P-TYP-A (J)  =  'P'  OR  =  'J'
005570         MOVE  1  TO  K
005580         PERFORM  INLINE-DISC  THRU  INLINE-EX.
005590 ADD-TO-J.
005600     ADD  1  TO  J.
005610     IF  J  =  I   NEXT  SENTENCE  ELSE
005620         GO  TO  SW-CK.
005630     MOVE  'T'  TO  SW-A (J).
005640 SW-CK-EX.
005650     EXIT.
005660 INLINE-DISC.
005670     IF  FR-INL-A (J)  =  FR-INLA (K)  OR  =  TO-INLA (K)
005680         AND  UMBIL (K)  =  'X'
005690         MOVE  'S'  TO  NON-SW
005700           MOVE  'S'  TO  SW-A (J)
005710           GO  TO  INLINE-EX.
005720     ADD  1  TO  K.
005730     IF  K  >  200
005740         GO  TO  INLINE-EX.
005750     GO  TO  INLINE-DISC.
005760 INLINE-EX.
005770     EXIT.
005780 XREF-CK.
005790     MOVE  PT-A (1)  TO  P-P-P-N.
005800     IF  LIN-CT  >  45
005810         WRITE DISKEE FROM HEAD-1  AFTER POSITIONING 0
005820         WRITE DISKEE FROM HEAD-2  AFTER POSITIONING 2
005830         WRITE DISKEE FROM HD-0    AFTER POSITIONING 2
005840         MOVE 1  TO  LIN-CT.
005850     WRITE DISKEE  FROM  HEAD-3  AFTER  POSITIONING 1.
005860     ADD  1  TO  LIN-CT.
005870 XREF-EX.
005880     EXIT.
005890 CLOSE-UP.
005900     DISPLAY  '  NORMAL  END  '
005910     DISPLAY  ' BRANCH SET DELETED DUE TO UNIQUE =       '
005920         DEL-UNIQUE.
005930     DISPLAY  ' BRANCH SET DELETED DUE TO DIRECTION =    '
005940         DEL-DIR.
005950     DISPLAY  ' BRANCH SET DELETED DUE TO NON-SWITCH =   '
005960         DEL-SW.
005970     DISPLAY ' TOTAL BRANCH SETS READ = ' TOT-BRA-SET.
005980     DISPLAY ' TOTAL SWITCH-PATHS      = ' SWITCH-PATHS.
005990     DISPLAY ' TOTAL NON-SWITCH-PATHS =  ' NON-SWITCH-PATHS.
006000     CLOSE   INLINE.
006010     CLOSE   PATH-IN.
006020     CLOSE   DISK-1.
006030     CLOSE  SRTD-FLE.
006040     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.         'BIDEDIT'.
000030 AUTHOR.             PHELPS/VAWTER.
000040 DATE-WRITTEN.       SEPTEMBER 1968/JANUARY 1969.
000050 REMARKS.
000060     THIS PROGRAM EDITS CARD INPUT, CHECKS IT TO ASSURE THAT IT
000070     MEETS CERTAIN SPECIFICATIONS AND RELEASES IT TO AN INTERNAL
000080     SORT WHICH SORTS THE DATA,
000090     THE PROGRAM THEN CHECKS FOR DUPLICATE INPUT RECORDS
000100     DELETING ONE OF THE DUPLICATE PAIR ACCORDING TO A
000110     PREDETERMINED ALGORITHM.
000120 ENVIRONMENT DIVISION.
000130 CONFIGURATION SECTION.
000140 SOURCE-COMPUTER.    IBM-360.
000150 OBJECT-COMPUTER.    IBM-360.
000160 INPUT-OUTPUT SECTION.
000170 FILE-CONTROL.
000180     SELECT INCARD ASSIGN TO UT-S-INCRD.
000190     SELECT INCARD2  ASSIGN TO UT-S-CRD2.
000200     SELECT OUTDATA ASSIGN TO UT-S-SORTOUT.
000210     SELECT EXCRPT ASSIGN TO UT-S-RPTOT.
000220     SELECT  GOODDATA  ASSIGN TO UT-S-GDATA.
000230     SELECT SORTIT ASSIGN TO UT-S-SD1.
000240 DATA DIVISION.
000250 FILE SECTION.
000260 FD  INCARD
000270     RECORDING MODE IS F
000280     LABEL RECORDS ARE OMITTED
000290     DATA RECORD IS CARDS1.
000300 01  CARDS1.
000310     02  FILLER  PICTURE X(80).
000320 FD  INCARD2
000330     RECORDING MODE IS F
000340     LABEL RECORDS ARE OMITTED
000350     DATA RECORD IS CARDS2.
000360 01  CARDS2.
000370     02  FILLER      PICTURE X(80).
000380 FD  OUTDATA
000390     RECORDING MODE IS F
000400     BLOCK CONTAINS 30 RECORDS
000410     LABEL RECORDS ARE OMITTED
000420     DATA RECORD IS OTREC.
000430 01  OTREC           PICTURE X(100).
000440 FD  GOODDATA
000450     RECORDING MODE IS F
000460     BLOCK CONTAINS 10 RECORDS
000470     LABEL RECORDS OMITTED
000480     DATA RECORD IS OUTAREA.
000490 01  OUTAREA.
000500     02  FILLER      PICTURE X(100).
000510 FD  EXCRPT
000520     RECORDING MODE IS F
000530     RECORD CONTAINS 132 CHARACTERS
000540     BLOCK CONTAINS 10 RECORDS
000550     LABEL RECORDS ARE OMITTED
000560     DATA RECORD IS EXCEPT.
000570 01  EXCEPT          PICTURE X(132).
000580 SD  SORTIT
000590     RECORDING MODE IS F
000600     DATA RECORD IS SRTREC.
000610 01  SRTREC.
000620     02  CD-TYPE     PICTURE XX.
000630     02  S-ACTCD     PICTURE X.
000640     02  S-BOXRF     PICTURE X(15).
000650     02  S-FCONN     PICTURE X(10).
000660     02  S-TCONN     PICTURE X(10).
000670     02  FILLER      PICTURE X(62).
000680 WORKING-STORAGE SECTION.
000690 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000700 77  PGE     PICTURE 9(3) VALUE ZERO.
000710 77  LNE     PICTURE 99   VALUE ZERO.
000720 77  MESS1   PICTURE X(30) VALUE 'INVALID CARD TYPE             '.
000730 77  MESS2   PICTURE X(30) VALUE 'INVALID CARD NUMBER           '.
000740 77  MESS3   PICTURE X(30) VALUE 'INVALID BOX REFERANCE DES.    '.
000750 77  MESS5   PICTURE X(30) VALUE 'INVALID CONTRACTOR CODE       '.
000760 77  MESS6   PICTURE X(30) VALUE 'INVALID AREA CODE             '.
000770 77  MESS8   PICTURE X(30) VALUE 'INVALID ACTION CODE           '.
000780 77  MESS9   PICTURE X(30) VALUE 'INVALID FROM CONNECTOR        '.
000790 77  MESS11  PICTURE X(30) VALUE 'INVALID TO CONNECTOR          '.
000800 77  MESS12  PICTURE X(30) VALUE ' FROM AND TO CONNECTORS EQUAL '.
000810 77  MESS13  PICTURE X(30) VALUE 'INVALID DIODE CHARACTER       '.
000820 77  MESS14  PICTURE X(30) VALUE 'INVALID IMPEDANCE DATA        '.
000830 77  F-CON-D-HOLD        PICTURE X(10).
000840 77  TAPE-END        PICTURE X(3)  VALUE SPACE.
000850 01  CRD-IN.
000860     02  CRD-CONT.
000870      03 CRDTP       PICTURE X.
000880      03 CRDNO       PICTURE X.
000890      03 ACTCD       PICTURE X.
000900      03 BOXRF       PICTURE X(15).
000910     02  CRD-DAT1.
000920      03 CNTRCD      PICTURE X.
000930      03 AREACD      PICTURE X.
000940      03 DRWGNO      PICTURE X(21).
000950      03 PARTNO      PICTURE X(20).
000960      03 BOXTTL      PICTURE X(19).
000970     02 CRD-DAT2  REDEFINES CRD-DAT1.
000980      03 F-CONN.
000990       04 FITM       PICTURE X.
001000       04 FILLER     PICTURE X(5).
001010       04 F-PIN      PICTURE X(4).
001020      03 T-CONN.
001030       04 TITM       PICTURE X.
001040       04 FILLER     PICTURE X(5).
001050       04 T-PIN      PICTURE X(4).
001060      03 DIODE       PICTURE X.
001070      03 IMPED       PICTURE X(3).
001080      03 RMRKS       PICTURE X(38).
001090     02  CRD-DAT3 REDEFINES CRD-DAT2.
001100      03 FILLER      PICTURE X(20).
001110      03 FILLER      PICTURE X(42).
001120 01  DATE-IN.
001130     02  INDATE      PICTURE X(8).
001140     02  FILLER      PICTURE X(72).
001150 01  W-CARD.
001160     02  W-CONTR     PICTURE X(18).
001170     02  W-DAT1.
001180      03 FILLER-W    PICTURE X(20).
001190      03 W-CNTRCD    PICTURE X.
001200      03 W-AREACD    PICTURE X.
001210      03 W-DRWGNO    PICTURE X(21).
001220      03 W-PARTNO    PICTURE X(20).
001230      03 W-BOXTTL    PICTURE X(19).
001240     02  W-DAT2 REDEFINES W-DAT1.
001250      03 W-FCONN     PICTURE X(10).
001260      03 W-TCONN     PICTURE X(10).
001270      03 W-DATA.
001280      04 W-DIODE     PICTURE X.
001290      04 W-IMPED     PICTURE X(3).
001300      04 W-RMRKS     PICTURE X(38).
001310      04 FILLER      PICTURE X(20).
001320 01  LINER.
001330     02  FILLER      PICTURE X(4)  VALUE SPACE.
001340     02  BAD-REC     PICTURE X(80).
001350     02  FILLER      PICTURE X(10) VALUE SPACE.
001360     02  MESSAGE     PICTURE X(30).
001370     02  FILLER      PICTURE X(8)  VALUE SPACE.
001380 01  HEADER.
001390     02  FILLER      PICTURE X(50) VALUE SPACE.
001400     02  FILLER      PICTURE X(16)
001410         VALUE 'BID ERROR REPORT'.
001420     02  FILLER      PICTURE X(30) VALUE SPACE.
001430     02  FILLER      PICTURE X(6)  VALUE 'PAGE  '.
001440     02  HPAGE       PICTURE 9(3).
001450     02  FILLER      PICTURE X(10) VALUE SPACE.
001460     02  FILLER      PICTURE X(6)  VALUE 'DATE  '.
001470     02  HDATE       PICTURE X(8).
001480     02  FILLER      PICTURE X(3)  VALUE SPACE.
001490 01  SRTREC-D.
001500         02  FILLER      PICTURE X(18).
001510         02  F-CON-D     PICTURE X(10).
001520         02  T-CON-D     PICTURE X(10).
001530         02  DIOD-D      PICTURE X.
001540         02  FILLER      PICTURE X(40).
001550         02  RMKS-38     PICTURE X.
001560         02  FILLER      PICTURE X(20).
001570 01  BACK-CARD.
001580     02  T-TYPE          PICTURE XX.
001590     02  AC-T            PICTURE X.
001600     02  T-ID.
001610         03  FILLER          PICTURE X(15).
001620         03  FROM-T          PICTURE X(10).
001630         03  TO-T            PICTURE X(10).
001640     02  B1-REST-T.
001650         03  CNTR-T      PICTURE X.
001660         03  AREA-T      PICTURE X.
001670         03  DWNO-T.
001680             04  DWNO-X  PICTURE X.
001690             04  FILLER  PICTURE X(20).
001700         03  UPRT-T.
001710             04  UPRT-X  PICTURE X.
001720             04  FILLER  PICTURE X(19).
001730         03  BOX-T.
001740             04  BOX-X   PICTURE X.
001750             04  FILLER  PICTURE X(18).
001760     02  B2-REST-T REDEFINES B1-REST-T.
001770         03  DIOD-T      PICTURE X.
001780         03  IMP-T.
001790             04  IMP-X   PICTURE X.
001800             04  FILLER  PICTURE X(2).
001810         03  RMKS-T.
001820             04  RMKS-X  PICTURE X.
001830             04  FILLER  PICTURE X(36).
001840         03  RMKS-38-T   PICTURE X.
001850         03  FILLER-T    PICTURE X(20).
001860 01  CARD-HOLD-1.
001870     02  C-TYPE          PICTURE XX.
001880     02  C-ACT           PICTURE X.
001890     02  C-ID            PICTURE X(35).
001900     02  C-DAT1.
001910         03  C-CNTR      PICTURE X.
001920         03  C-AREA      PICTURE X.
001930         03  C-DWNO      PICTURE X(21).
001940         03  C-UPRT      PICTURE X(20).
001950         03  C-BOX       PICTURE X(19).
001960     02  C-DAT2 REDEFINES C-DAT1.
001970         03  C-DIOD      PICTURE X.
001980         03  C-IMP       PICTURE X(3).
001990         03  C-RMKS      PICTURE X(37).
002000         03  FILLER      PICTURE X.
002010         03  FILLER-C    PICTURE X(20).
002020 01  ERROR-OUT.
002030     02  FILLER          PICTURE X(32)   VALUE
002040                ' ACTION CODE NOT I, R, OR D     '.
002050     02  BAD-ACT         PICTURE X(100).
002060 01  DUP-REC.
002070     02  FILLER          PICTURE X(32)   VALUE
002080                ' DUPLICATE RECORD FOUND DELETED '.
002090     02  DUP-TRAN        PICTURE X(100).
002100 PROCEDURE DIVISION.
002110 SORT-DATA-RECORDS.
002120     OPEN OUTPUT EXCRPT.
002130     SORT SORTIT ON ASCENDING KEY
002140     S-BOXRF S-FCONN S-TCONN S-ACTCD
002150     INPUT PROCEDURE INPUT-PROCEDURE
002160     GIVING OUTDATA.
002170     CLOSE INCARD.
002180     CLOSE INCARD2.
002190 STRIP-OUT-DUP-REC.
002200     OPEN INPUT OUTDATA.
002210                             NOTE -------------------------------
002220                             THIS SECTION REMOVES DUPLICATE
002230                             RECORDS BEFORE THEY ARE PASSED
002240                             TO THE UPDATE PROGRAM
002250                             -----------------------------------.
002260     OPEN OUTPUT GOODDATA.
002270     MOVE SPACES TO LINER HDATE. MOVE 1 TO HPAGE.
002280     WRITE EXCEPT FROM LINER  AFTER POSITIONING 0.
002290     WRITE EXCEPT FROM HEADER AFTER POSITIONING 3.
002300     WRITE EXCEPT FROM LINER  AFTER POSITIONING 1.
002310 READ-1.
002320     MOVE SPACES TO CARD-HOLD-1.
002330     READ OUTDATA INTO CARD-HOLD-1 AT END GO TO DATA-LEFT-NO.
002340 CHECK-C-ACT.
002350     IF C-ACT = 'D' NEXT SENTENCE
002360             ELSE
002370                   GO TO C-C-A.
002380 C-ACT-EQ-D.
002390     READ OUTDATA INTO BACK-CARD AT END GO TO DATA-LEFT-YES.
002400     IF T-TYPE = C-TYPE  AND
002410         AC-T   = C-ACT   AND
002420         T-ID   = C-ID    NEXT SENTENCE
002430     ELSE
002440         WRITE OUTAREA FROM CARD-HOLD-1
002450         MOVE BACK-CARD TO CARD-HOLD-1
002460         GO TO C-C-A.
002470     IF  FROM-T < TO-T  PERFORM DELETE-AST THRU D-A-END
002480         ELSE
002490                         PERFORM DELETE-NON-AST THRU D-N-A-END.
002500     WRITE EXCEPT FROM DUP-REC AFTER POSITIONING 2.
002510     GO TO C-ACT-EQ-D.
002520 C-C-A.
002530     IF C-ACT = 'D' GO TO C-ACT-EQ-D.
002540     IF C-ACT = 'I' GO TO READ-2.
002550     IF C-ACT = 'R' NEXT SENTENCE
002560         ELSE MOVE CARD-HOLD-1 TO BAD-ACT
002570              WRITE EXCEPT FROM ERROR-OUT AFTER POSITIONING 2.
002580 READ-3.
002590     READ OUTDATA INTO BACK-CARD AT END GO TO DATA-LEFT-YES.
002600     IF ((T-TYPE = C-TYPE) AND (AC-T = C-ACT) AND (T-ID = C-ID))
002610                 NEXT SENTENCE
002620         ELSE
002630                 WRITE OUTAREA FROM CARD-HOLD-1
002640                 MOVE BACK-CARD TO CARD-HOLD-1
002650                 GO TO CHECK-C-ACT.
002660     IF  FROM-T < TO-T  PERFORM DELETE-AST THRU D-A-END
002670         ELSE
002680                        PERFORM DELETE-NON-AST THRU D-N-A-END.
002690     WRITE EXCEPT FROM DUP-REC AFTER POSITIONING 2.
002700     GO TO READ-3.
002710 READ-2.
002720     MOVE SPACES TO BACK-CARD.
002730     READ OUTDATA INTO BACK-CARD AT END GO TO DATA-LEFT-YES.
002740     IF AC-T = 'I' GO TO AC-T-EQ-I.
002750     IF AC-T = 'R' GO TO AC-T-EQ-R.
002760     IF AC-T = 'D'  GO TO AC-T-EQ-D
002770         ELSE
002780                 MOVE BACK-CARD TO BAD-ACT
002790                 WRITE EXCEPT FROM ERROR-OUT AFTER POSITIONING 2.
002800                 GO TO READ-2.
002810 AC-T-EQ-D.
002820     WRITE OUTAREA FROM CARD-HOLD-1.
002830     MOVE BACK-CARD TO CARD-HOLD-1.
002840 ATED-1.
002850     READ OUTDATA INTO BACK-CARD AT END GO TO DATA-LEFT-YES.
002860     IF  T-TYPE = C-TYPE AND
002870         AC-T   = C-ACT  AND
002880         T-ID   = C-ID   NEXT SENTENCE
002890     ELSE
002900         WRITE OUTAREA FROM CARD-HOLD-1
002910         MOVE BACK-CARD TO CARD-HOLD-1
002920         GO TO CHECK-C-ACT.
002930     IF  FROM-T < TO-T  PERFORM DELETE-AST THRU D-A-END
002940         ELSE
002950                        PERFORM DELETE-NON-AST THRU D-N-A-END.
002960     WRITE EXCEPT FROM DUP-REC AFTER POSITIONING 2.
002970     GO TO ATED-1.
002980 AC-T-EQ-I.
002990     IF ((C-TYPE = T-TYPE) AND (T-ID = C-ID))  NEXT SENTENCE
003000         ELSE
003010                 WRITE OUTAREA FROM CARD-HOLD-1
003020                 MOVE BACK-CARD TO CARD-HOLD-1
003030                 GO TO READ-2.
003040     IF  FROM-T < TO-T  PERFORM DELETE-AST THRU D-A-END
003050         ELSE
003060                        PERFORM DELETE-NON-AST THRU D-N-A-END.
003070     WRITE EXCEPT FROM DUP-REC AFTER POSITIONING 2.
003080                 GO TO READ-2.
003090 DELETE-AST-NOTES.
003100                             NOTE -------------------------------
003110                             WHEN DUPLICATE RECORDS ARE FOUND,
003120                             THIS PARAGRAPH DELETES THE RECORD
003130                             WHICH IS THE REVERSE
003140                             -----------------------------------.
003150 DELETE-AST.
003160     IF RMKS-38-T = '*' MOVE BACK-CARD TO DUP-TRAN
003170         ELSE
003180                         MOVE CARD-HOLD-1 TO DUP-TRAN
003190                         MOVE BACK-CARD TO CARD-HOLD-1.
003200 D-A-END.
003210     EXIT.
003220 DELETE-NON-AST-NOTES.
003230                             NOTE -------------------------------
003240                             WHEN DUPLICATE RECORDS ARE FOUND,
003250                             THIS PARAGRAPH DELETES THE RECORD
003260                             WHICH IS THE ORIGINAL
003270                             -----------------------------------.
003280 DELETE-NON-AST.
003290     IF RMKS-38-T = '*' MOVE CARD-HOLD-1 TO DUP-TRAN
003300                        MOVE BACK-CARD TO CARD-HOLD-1
003310         ELSE
003320                        MOVE BACK-CARD TO DUP-TRAN.
003330 D-N-A-END.
003340     EXIT.
003350 AC-T-EQ-R.
003360         IF ((T-TYPE = C-TYPE) AND (T-ID = C-ID)) GO TO   UPDT-I.
003370         WRITE OUTAREA FROM CARD-HOLD-1.
003380         MOVE BACK-CARD TO CARD-HOLD-1.
003390         GO TO READ-3.
003400 UPDT-I.
003410     PERFORM UPDATE-I THRU UPDATE-END.
003420     WRITE OUTAREA FROM CARD-HOLD-1.
003430 READ-4.
003440     READ OUTDATA INTO CARD-HOLD-1 AT END GO TO DATA-LEFT-NO.
003450     IF ((C-TYPE = T-TYPE) AND (AC-T = C-ACT) AND (T-ID = C-ID))
003460                 MOVE CARD-HOLD-1 TO DUP-TRAN
003470                 WRITE EXCEPT FROM DUP-REC AFTER POSITIONING 2
003480                 GO TO READ-4
003490     ELSE        GO TO CHECK-C-ACT.
003500 UPDATE-I.
003510     IF C-TYPE = 'B2' GO TO B2-REVISE.
003520                             NOTE -------------------------------
003530                             UPDATE-I THRU UPDATE-END WILL UPDATE
003540                             AN ADD TRANSACTION IF IT IS FOLLOWED
003550                             BY A REVISION TRANSACTION
003560                             -----------------------------------.
003570     IF CNTR-T = '@' MOVE SPACE  TO C-CNTR GO TO CK-AREA.
003580     IF CNTR-T = SPACE NEXT SENTENCE
003590             ELSE MOVE CNTR-T TO C-CNTR.
003600 CK-AREA.
003610     IF AREA-T = '@' MOVE SPACE TO C-AREA GO TO CK-DWNO.
003620     IF AREA-T = SPACE NEXT SENTENCE
003630             ELSE MOVE AREA-T TO C-AREA.
003640 CK-DWNO.
003650     IF DWNO-X = '@' MOVE SPACE TO C-DWNO GO TO CK-UPRT.
003660     IF DWNO-T = SPACES NEXT SENTENCE
003670             ELSE MOVE DWNO-T TO C-DWNO.
003680 CK-UPRT.
003690     IF UPRT-X = '@' MOVE SPACES TO C-UPRT GO TO CK-BOX.
003700     IF UPRT-T = SPACES NEXT SENTENCE
003710             ELSE MOVE UPRT-T TO C-UPRT.
003720 CK-BOX.
003730     IF BOX-X = '@' MOVE SPACES TO C-BOX GO TO UPDATE-END.
003740     IF BOX-T = SPACES NEXT SENTENCE
003750             ELSE MOVE BOX-T TO C-BOX.
003760     GO TO UPDATE-END.
003770 B2-REVISE.
003780     IF DIOD-T = '@' MOVE SPACE TO C-DIOD GO TO CK-IMP.
003790     IF DIOD-T = SPACE NEXT SENTENCE
003800             ELSE MOVE DIOD-T TO C-DIOD.
003810 CK-IMP.
003820     IF IMP-X = '@' MOVE SPACE TO C-IMP GO TO CK-RMKS.
003830     IF IMP-T = SPACE NEXT SENTENCE
003840             ELSE MOVE IMP-T TO C-IMP.
003850 CK-RMKS.
003860     IF RMKS-X = '@' MOVE SPACE TO C-RMKS GO TO MOVE-REST-T.
003870     IF RMKS-T = SPACE NEXT SENTENCE
003880             ELSE MOVE RMKS-T TO C-RMKS.
003890 MOVE-REST-T.
003900     MOVE FILLER-T TO FILLER-C.
003910 UPDATE-END.
003920     EXIT.
003930 DATA-LEFT-YES.
003940     WRITE OUTAREA FROM CARD-HOLD-1.
003950 DATA-LEFT-NO.
003960     CLOSE OUTDATA.
003970     CLOSE GOODDATA.
003980     CLOSE EXCRPT.
003990     STOP RUN.
004000 INPUT-PROCEDURE SECTION.
004010     OPEN INPUT INCARD.
004020     OPEN INPUT INCARD2.
004030 READ-DATE-CARD.
004040     READ INCARD INTO DATE-IN AT END GO TO END-EX.
004050     MOVE INDATE TO HDATE.
004060     PERFORM WRITE-HEADER.
004070 READ-DATA-CARDS.
004080     MOVE SPACE TO SRTREC  W-CARD.
004090                             NOTE -------------------------------
004100                             THIS IS SET UP TO READ MULTIPLE INPUT
004110                             -----------------------------------.
004120     IF TAPE-END = 'YES'
004130         READ INCARD2 INTO  CRD-IN AT END GO TO END-EX
004140       ELSE
004150     READ INCARD INTO  CRD-IN AT END MOVE 'YES' TO TAPE-END
004160                                     GO TO READ-DATA-CARDS.
004170 CHECK-CRDTP-CRDNO.
004180     IF CRDTP NOT = 'B'
004190     MOVE MESS1 TO MESSAGE
004200     GO TO WRITE-EXCEPTION-REPORT.
004210     IF CRDNO = '1' GO TO CARD-1.
004220     IF CRDNO = '2' GO TO CARD-2.
004230     MOVE MESS2 TO MESSAGE.
004240     GO TO WRITE-EXCEPTION-REPORT.
004250 CARD-1-NOTES.
004260     NOTE ********************************************************
004270          THIS ROUTINE CHECKS FOR INVALID DATA IN THE B1 CARDS AND
004280          AFTERWARD MOVES THE DATA TO THE SORT RECORD WHICH IS
004290          THEN RELEASED TO THE SORT.
004300     ************************************************************.
004310 CARD-1.
004320     IF BOXRF = SPACE
004330     MOVE MESS3 TO MESSAGE
004340     GO TO WRITE-EXCEPTION-REPORT.
004350 CARD-1-ACTION.
004360     IF ACTCD = 'D' GO TO CARD1-MOVE-CONTROL.
004370     IF ACTCD = 'A' GO TO CARD1A-ACTION.
004380     IF ACTCD = 'R' GO TO CARD1R-ACTION.
004390     MOVE MESS8 TO MESSAGE
004400     GO TO WRITE-EXCEPTION-REPORT.
004410 CARD1A-ACTION.
004420     MOVE 'I' TO ACTCD.
004430     IF CNTRCD = 'N' OR 'G' OR 'A'
004440     NEXT SENTENCE ELSE
004450     MOVE MESS5 TO MESSAGE
004460     GO TO WRITE-EXCEPTION-REPORT.
004470     IF AREACD = 'C' OR 'L' OR 'S' OR 'A' OR 'E' OR 'G'
004480     NEXT SENTENCE ELSE
004490     MOVE MESS6 TO MESSAGE
004500     GO TO WRITE-EXCEPTION-REPORT.
004510     GO TO CARD1-MOVE-DATA.
004520 CARD1R-ACTION.
004530     IF CNTRCD = 'N' OR 'G' OR 'A' OR SPACE
004540     NEXT SENTENCE ELSE
004550     MOVE MESS5 TO MESSAGE
004560     GO TO WRITE-EXCEPTION-REPORT.
004570     IF AREACD = 'C' OR 'L' OR 'S' OR 'A' OR 'E' OR 'G' OR SPACE
004580     NEXT SENTENCE ELSE
004590     MOVE MESS6 TO MESSAGE
004600     GO TO WRITE-EXCEPTION-REPORT.
004610 CARD1-MOVE-DATA.
004620     MOVE SPACE TO FILLER-W.
004630     MOVE CNTRCD TO W-CNTRCD.
004640     MOVE AREACD TO W-AREACD.
004650     MOVE DRWGNO TO W-DRWGNO.
004660     MOVE PARTNO TO W-PARTNO.
004670     MOVE BOXTTL TO W-BOXTTL.
004680 CARD1-MOVE-CONTROL.
004690     MOVE CRD-CONT TO W-CONTR.
004700     MOVE W-CARD TO SRTREC.
004710     GO TO RELEASE-SORT-RECORD.
004720 CARD-2-NOTES.
004730     NOTE ********************************************************
004740          THIS ROUTINE CHECKS FOR INVALID DATA IN THE B2 CARDS AND
004750          AFTERWARD MOVES THE DATA TO THE SORT RECORD WHICH IS
004760          THEN RELEASED TO THE SORT.
004770     ************************************************************.
004780 CARD-2.
004790     IF BOXRF = SPACE
004800     MOVE MESS3 TO MESSAGE
004810     GO TO WRITE-EXCEPTION-REPORT.
004820     IF FITM = SPACE
004830     MOVE MESS9 TO MESSAGE
004840     GO TO WRITE-EXCEPTION-REPORT.
004850     IF TITM = SPACE
004860     MOVE MESS11 TO MESSAGE
004870     GO TO WRITE-EXCEPTION-REPORT.
004880     IF F-PIN = SPACE
004890     NEXT SENTENCE ELSE
004900     EXAMINE F-PIN REPLACING ALL ' ' BY '0'.
004910     IF T-PIN = SPACE
004920     NEXT SENTENCE ELSE
004930     EXAMINE T-PIN REPLACING ALL ' ' BY '0'.
004940 CARD-2-ACTION.
004950     IF ACTCD = 'D'
004960     GO TO CARD2-MOVE-CONTROL.
004970     IF ACTCD = 'A'
004980     GO TO CARD2A-ACTION.
004990     IF ACTCD = 'R'
005000     GO TO CARD2R-ACTION.
005010     MOVE MESS8 TO MESSAGE.
005020     GO TO WRITE-EXCEPTION-REPORT.
005030 CARD2A-ACTION.
005040     MOVE 'I' TO ACTCD.
005050     IF DIODE = '+' OR '-' OR '0'
005060     GO TO CARD2A-IMPED-CHECK.
005070     IF DIODE = SPACE
005080     MOVE '0' TO DIODE
005090     GO TO CARD2A-IMPED-CHECK ELSE
005100     MOVE MESS13 TO MESSAGE
005110     GO TO WRITE-EXCEPTION-REPORT.
005120 CARD2A-IMPED-CHECK.
005130     EXAMINE IMPED REPLACING ALL ' ' BY '0'.
005140     IF IMPED NOT NUMERIC
005150     MOVE MESS14 TO MESSAGE
005160     GO TO WRITE-EXCEPTION-REPORT.
005170     GO TO CARD2-MOVE-DATA.
005180 CARD2R-ACTION.
005190     IF DIODE = '+' OR '-' OR '0' OR SPACE
005200     NEXT SENTENCE ELSE
005210     MOVE MESS13 TO MESSAGE
005220     GO TO WRITE-EXCEPTION-REPORT.
005230     IF IMPED NOT NUMERIC
005240     NEXT SENTENCE ELSE
005250     GO TO CARD2-MOVE-DATA.
005260     MOVE SPACE TO IMPED.
005270     GO TO CARD2-MOVE-DATA.
005280 CARD2-MOVE-DATA.
005290     MOVE DIODE TO W-DIODE.
005300     MOVE IMPED TO W-IMPED.
005310     MOVE RMRKS TO W-RMRKS.
005320 CARD2-MOVE-CONTROL.
005330     MOVE CRD-CONT TO W-CONTR.
005340     MOVE F-CONN TO W-FCONN.
005350     MOVE T-CONN TO W-TCONN.
005360     MOVE W-CARD TO SRTREC.
005370 RELEASE-SORT-RECORD.
005380     IF CD-TYPE = 'B2' AND S-FCONN = S-TCONN
005390                 MOVE MESS12 TO MESSAGE
005400                 GO TO WRITE-EXCEPTION-REPORT.
005410     IF CD-TYPE = 'B2' PERFORM FLIP-IT THRU FLIP-IT-END.
005420     RELEASE SRTREC.
005430 EXIT-RELEASE.
005440     GO TO READ-DATA-CARDS.
005450 WRITE-EXCEPTION-REPORT.
005460     MOVE CRD-IN TO BAD-REC.
005470     WRITE EXCEPT FROM LINER AFTER POSITIONING 2.
005480     ADD 2 TO LNE.
005490     IF LNE > 58
005500     PERFORM WRITE-HEADER.
005510     GO TO READ-DATA-CARDS.
005520 FLIP-IT.
005530     MOVE SRTREC TO SRTREC-D.
005540                             NOTE -------------------------------
005550                             THIS PARAGRAPH RELEASES THE RECORD
005560                             TO SORT AND CREATES THE REVERSE OF
005570                             THE RECORD
005580                             -----------------------------------.
005590     RELEASE SRTREC.
005600     MOVE F-CON-D TO F-CON-D-HOLD.
005610     MOVE T-CON-D TO F-CON-D.
005620     MOVE F-CON-D-HOLD TO T-CON-D.
005630     IF DIOD-D = '+' MOVE '-' TO DIOD-D  GO TO FP-1.
005640     IF DIOD-D = '-' MOVE '+' TO DIOD-D.
005650 FP-1.   MOVE '*' TO RMKS-38.
005660     MOVE SRTREC-D TO SRTREC.
005670 FLIP-IT-END.
005680     EXIT.
005690 WRITE-HEADER.
005700     ADD 1 TO PGE.
005710     MOVE PGE TO HPAGE.
005720     MOVE 4 TO LNE.
005730     MOVE SPACE TO LINER.
005740     WRITE EXCEPT FROM LINER AFTER POSITIONING 0.
005750     WRITE EXCEPT FROM HEADER AFTER POSITIONING 3.
005760     WRITE EXCEPT FROM LINER AFTER POSITIONING 1.
005770 END-EX.
005780     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.             'BIDUPDTE'.
000030 AUTHOR.                 JESSE VAWTER.
000040 DATE-WRITTEN.           JANUARY 13, 1969.
000050 REMARKS.
000060     THIS PROGRAM INPUTS 100-CHARACTER TRANSACTIONS AND USES THEM
000070     TO UPDATE A 100-CHARACTER MASTER FILE.
000080 ENVIRONMENT DIVISION.
000090 CONFIGURATION SECTION.
000100 SOURCE-COMPUTER.        IBM-360.
000110 OBJECT-COMPUTER.        IBM-360.
000120 INPUT-OUTPUT SECTION.
000130 FILE-CONTROL.
000140     SELECT TRANS     ASSIGN TO  UT-S-TRANSIN.
000150     SELECT MASTER    ASSIGN TO  UT-S-OLDMAST.
000160     SELECT OUT-MAST  ASSIGN TO  UT-S-NEWMAST.
000170     SELECT TEMP-STOR ASSIGN TO  UT-S-INTSTOR.
000180     SELECT REPRT     ASSIGN TO  UT-S-RPT.
000190     SELECT CARDIN    ASSIGN TO  UT-S-CRD.
000200     SELECT ERR-REPT ASSIGN TO UT-S-ERROT.
000210     SELECT PURE-MAST ASSIGN TO UT-S-PMAST.
000220     SELECT INDEX-TABL ASSIGN TO UT-S-IND.
000230 DATA DIVISION.
000240 FILE SECTION.
000250 FD  PURE-MAST
000260     RECORDING MODE IS F
000270     BLOCK CONTAINS  10 RECORDS
000280     LABEL RECORDS ARE OMITTED
000290     DATA RECORD IS NMF.
000300 01  NMF.
000310     02  FILLER      PICTURE X(100).
000320 FD  ERR-REPT
000330     RECORDING MODE IS F
000340     BLOCK CONTAINS 1 RECORDS
000350     LABEL RECORDS ARE OMITTED
000360     DATA RECORD IS ELINE.
000370 01  ELINE.
000380     02  FILLER      PICTURE X(132).
000390 FD  TRANS
000400     RECORDING MODE IS F
000410     BLOCK CONTAINS 10 RECORDS
000420     LABEL RECORDS ARE OMITTED
000430     DATA RECORD IS TRANS-ACT.
000440 01  TRANS-ACT.
000450     02  FILLER      PICTURE X(100).
000460 FD  MASTER
000470     RECORDING MODE IS F
000480     BLOCK CONTAINS 10 RECORDS
000490     LABEL RECORDS ARE OMITTED
000500     DATA RECORD IS MAST.
000510 01  MAST.
000520     02  FILLER      PICTURE X(100).
000530 FD  OUT-MAST
000540     RECORDING MODE IS F
000550     BLOCK CONTAINS 10 RECORDS
000560     LABEL RECORDS ARE OMITTED
000570     DATA RECORD IS NEW-MAST.
000580 01  NEW-MAST.
000590     02  FILLER      PICTURE X(100).
000600 FD  REPRT
000610     RECORDING MODE IS F
000620     BLOCK CONTAINS 7 RECORDS
000630     LABEL RECORDS ARE OMITTED
000640     DATA RECORD IS LINER.
000650 01  LINER.
000660     02  FILLER          PICTURE X(132).
000670 FD  CARDIN
000680     RECORDING MODE IS F
000690     BLOCK CONTAINS 1 RECORDS
000700     LABEL RECORDS ARE OMITTED
000710     DATA RECORD IS CARDD.
000720 01  CARDD.
000730     02  REPT-DATE       PICTURE X(8).
000740     02  FILLER          PICTURE X(2).
000750     02  CSM-I           PICTURE X(7).
000760     02  FILLER          PICTURE X(03).
000770     02  LM-I           PICTURE X(7).
000780     02  FILLER          PICTURE X(53).
000790 FD  TEMP-STOR
000800     RECORDING MODE IS F
000810     BLOCK CONTAINS 10 RECORDS
000820     LABEL RECORDS ARE OMITTED
000830     DATA RECORD IS INT-STOR.
000840 01  INT-STOR.
000850     02  FILLER      PICTURE X(100).
000860 FD  INDEX-TABL
000870     RECORDING MODE IS F
000880     BLOCK CONTAINS 10 RECORDS
000890     LABEL RECORDS ARE OMITTED
000900     DATA RECORD IS INDX.
000910 01  INDX.
000920     02  FILLER      PICTURE X(132).
000930 WORKING-STORAGE SECTION.
000940 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000950 77  I               PICTURE 9999    VALUE ZERO.
000960 77  J               PICTURE 9999    VALUE ZERO.
000970 77  K       PICTURE 9999  VALUE ZERO.
000980 77  G-REC-CNTR          PICTURE 99999 VALUE ZERO.
000990 77  B1-M-BRD-SAVE       PICTURE X(15) VALUE SPACE.
001000 77  BRD-SAVE       PICTURE X(15)   VALUE SPACE.
001010 77  BRD-HOLD        PICTURE X(15)   VALUE SPACE.
001020 77  TA-SW           PICTURE X(3)    VALUE SPACE.
001030 77  LNE-CNT         PICTURE 9(2)    VALUE ZERO.
001040 77  ERR-LOC         PICTURE X   VALUE SPACE.
001050 01  INDEX-TITLE.
001060     02  FILLER      PICTURE X(10)   VALUE SPACE.
001070     02  FILLER      PICTURE X(25)   VALUE
001080            'BOX REFERENCE DESIGNATOR '.
001090     02  FILLER      PICTURE X(97)   VALUE SPACE.
001100 01  BRD-INDEX.
001110     02  FILLER      PICTURE X(10)   VALUE SPACE.
001120     02  BRD-INDX    PICTURE X(15).
001130     02  FILLER      PICTURE X(107)  VALUE SPACE.
001140 01  MAST-HOLD.
001150     02  MASTER-TYPE         PICTURE XX.
001160     02  ACT-CODE-M      PICTURE X.
001170     02  M-ID.
001180         03  M-BRD           PICTURE X(15).
001190         03  M-FROM          PICTURE X(10).
001200         03  M-FROM-2 REDEFINES M-FROM.
001210             04  FROM-I      PICTURE X(6).
001220             04  FROM-P      PICTURE X(4).
001230         03  M-TO            PICTURE X(10).
001240         03  M-TO-2  REDEFINES  M-TO.
001250             04  TO-I        PICTURE X(6).
001260             04  TO-P        PICTURE X(4).
001270     02  B1-REST-M.
001280         03  CNTR-M          PICTURE X.
001290         03  AREA-M          PICTURE X.
001300         03  DRAW-NO-M       PICTURE X(21).
001310         03  UNIT-PART-M     PICTURE X(20).
001320         03  BOX-TITLE-M     PICTURE X(19).
001330     02  B2-REST-M REDEFINES B1-REST-M.
001340         03  DIOD-M          PICTURE X.
001350         03  IMP-M           PICTURE 99V9.
001360         03  REMARKS-M       PICTURE X(37).
001370         03  RMK-FILLER      PICTURE X.
001380         03  FILLER          PICTURE X(20).
001390 01  TA.
001400     02  TA-TYPE             PICTURE XX.
001410     02  ACTION-CODE         PICTURE X.
001420     02  T-ID.
001430         03  T-BRD           PICTURE X(15).
001440         03  FILLER          PICTURE X(20).
001450     02  B1-REST-T.
001460         03  CNTR-T          PICTURE X.
001470         03  AREA-T          PICTURE X.
001480         03  DRAW-NO-T.
001490             04  DRAW-NO-TX  PICTURE X.
001500             04  FILLER      PICTURE X(20).
001510         03  UNIT-PART-T.
001520             04  UNIT-PART-X PICTURE X.
001530             04  FILLER      PICTURE X(19).
001540         03  BOX-TITLE-T.
001550             04  BOX-TITLE-X PICTURE X.
001560             04  FILLER      PICTURE X(18).
001570     02  B2-REST-T REDEFINES B1-REST-T.
001580         03  DIOD-T          PICTURE X.
001590         03  IMP-T1          PICTURE 99V9.
001600         03  IMP-T REDEFINES IMP-T1.
001610             04  IMP-TX      PICTURE X.
001620             04  FILLER      PICTURE X(2).
001630         03  REMARKS-T.
001640             04  REMARKS-TX  PICTURE X.
001650             04  FILLER      PICTURE X(36).
001660         03  RMK-LAST        PICTURE X.
001670         03  FILLER          PICTURE X(20).
001680 01  TEMP-DATA-STORAGE.
001690     02  TYPE-I              PICTURE XX.
001700     02  ACT-I           PICTURE X.
001710     02  ID-I.
001720         03  FILLER      PICTURE X(35).
001730     02  B1-REST-I.
001740         03  FILLER          PICTURE X(62).
001750     02  B2-REST-I REDEFINES B1-REST-I.
001760         03  FILLER          PICTURE X(62).
001770 01  M-ID-SAVE.
001780     02  M-BRD-SAVE          PICTURE X(15)   VALUE SPACE.
001790     02  FILLER              PICTURE X(20)   VALUE SPACE.
001800 01  B1-DELETE.
001810     02  FILLER      PICTURE X(02)   VALUE SPACE.
001820     02  FILLER      PICTURE X(21)   VALUE
001830            'THIS BOX DELETED     '.
001840     02  FILLER      PICTURE X(39)   VALUE SPACE.
001850 01  B2-WO-B1.
001860     02  FILLER          PICTURE X(48)   VALUE
001870        '    THE FOLLOWING RECORDS WERE DELETED FROM THE '.
001880     02  FILLER          PICTURE X(52)   VALUE
001890        'MASTER-FILE BECAUSE NO CORRESPONDING B1 RECORDS WERE'.
001900     02  FILLER          PICTURE X(6)    VALUE
001910        ' FOUND'.
001920     02  FILLER          PICTURE X(26)    VALUE SPACE.
001930 01  M-DELETED.
001940     02  FILLER          PICTURE X(10)   VALUE SPACE.
001950     02  M-DELETE        PICTURE X(100).
001960     02  FILLER          PICTURE X(22)   VALUE SPACE.
001970 01  B2-DELETE.
001980     02  FILLER      PICTURE X(10)   VALUE SPACE.
001990     02  FILLER      PICTURE X(14)   VALUE 'RECORD DELETED'.
002000     02  FILLER      PICTURE X(38)   VALUE SPACE.
002010 01  ARRAY-BRD.
002020     02  BRD-A  OCCURS   1000 TIMES.
002030         03  BRD-T   PICTURE X(15).
002040 01  ERR2.
002050     02  FILLER          PICTURE X(49)   VALUE
002060        ' ATTEMPTING TO REVISE OR DELETE ITEM NOT ON FILE '.
002070     02  FILLER      PICTURE X(83)   VALUE SPACE.
002080 01  ERR8.
002090     02  FILLER      PICTURE X   VALUE SPACE.
002100     02  BAD-RKD     PICTURE X(100)  VALUE SPACE.
002110     02  FILLER      PICTURE X(31)   VALUE SPACE.
002120 01  ERR5.
002130     02  FILLER          PICTURE X(40)   VALUE
002140           ' TA-TYPE SHOULD HAVE BEEN B1 OR B2      '.
002150     02  FILLER          PICTURE X(92)   VALUE SPACE.
002160 01  ERR6.
002170     02  FILLER          PICTURE X(42)   VALUE
002180         ' ATTEMPTING TO ADD ITEM ALREADY ON FILE   '.
002190     02  FILLER          PICTURE X(90)   VALUE SPACE.
002200 01  ASTR.
002210     02  FILLER          PICTURE X       VALUE SPACE.
002220     02  FILLER          PICTURE X(50)   VALUE ALL '*'.
002230     02  FILLER          PICTURE X(81)   VALUE SPACE.
002240 01  BLANK-LINE.
002250     02  FILLER          PICTURE X(132)  VALUE SPACE.
002260 01  HEAD-11.
002270     02  FILLER      PICTURE X(35)   VALUE
002280         ' * CT * A *                  $ CA *'.
002290     02  FILLER      PICTURE X(25)   VALUE SPACE.
002300     02  FILLER      PICTURE X       VALUE '*'.
002310     02  FILLER      PICTURE X(25)   VALUE SPACE.
002320     02  FILLER      PICTURE X       VALUE '*'.
002330     02  FILLER      PICTURE X(26)   VALUE SPACE.
002340     02  FILLER      PICTURE X       VALUE '*'.
002350     02  FILLER          PICTURE X(18)   VALUE SPACE.
002360 01  HEAD-12.
002370     02  FILLER      PICTURE X(35)   VALUE
002380         ' * AY * C *       BOX        $ NR *'.
002390     02  FILLER      PICTURE X(25)   VALUE SPACE.
002400     02  FILLER      PICTURE X       VALUE '*'.
002410     02  FILLER      PICTURE X(25)   VALUE SPACE.
002420     02  FILLER      PICTURE X       VALUE '*'.
002430     02  FILLER      PICTURE X(26)   VALUE SPACE.
002440     02  FILLER      PICTURE X       VALUE '*'.
002450     02  FILLER          PICTURE X(18)   VALUE SPACE.
002460 01  HEAD-13.
002470     02  FILLER      PICTURE X(35)   VALUE
002480         ' * RP * T *    REFERENCE     $ TE *'.
002490     02  FILLER      PICTURE X(52)   VALUE
002500         '     DRAWING NUMBER      *     UNIT PART NUMBER    *'.
002510     02  FILLER      PICTURE X(27)   VALUE
002520         '        BOX TITLE         *'.
002530     02  FILLER          PICTURE X(18)   VALUE SPACE.
002540 01  HEAD-14.
002550     02  FILLER      PICTURE X(37)   VALUE
002560         ' * DE *3  *4   DESIGNATOR  18$ RA *21'.
002570     02  FILLER      PICTURE X(23)   VALUE SPACE.
002580     02  FILLER      PICTURE X(3)    VALUE '*42'.
002590     02  FILLER      PICTURE X(23)   VALUE SPACE.
002600     02  FILLER      PICTURE X(3)    VALUE '*62'.
002610     02  FILLER      PICTURE X(24)   VALUE SPACE.
002620     02  FILLER      PICTURE X       VALUE '*'.
002630     02  FILLER          PICTURE X(18)   VALUE SPACE.
002640 01  HEAD-15.
002650     02  FILLER      PICTURE X(35)   VALUE
002660         ' *    *   *                  $    *'.
002670     02  FILLER      PICTURE X(25)   VALUE SPACE.
002680     02  FILLER      PICTURE X       VALUE '*'.
002690     02  FILLER      PICTURE X(25)   VALUE SPACE.
002700     02  FILLER      PICTURE X       VALUE '*'.
002710     02  FILLER      PICTURE X(26)   VALUE SPACE.
002720     02  FILLER      PICTURE X       VALUE '*'.
002730     02  FILLER          PICTURE X(18)   VALUE SPACE.
002740 01  HEAD-21.
002750     02  FILLER      PICTURE X(54)   VALUE
002760         ' * CT * A *       BOX        *     FROM      *      TO'.
002770     02  FILLER      PICTURE X(19)   VALUE
002780         '       $ D *  IMP *'.
002790     02  FILLER      PICTURE X(40)   VALUE SPACE.
002800     02  FILLER      PICTURE X       VALUE '*'.
002810     02  FILLER          PICTURE X(18)   VALUE SPACE.
002820 01  HEAD-22.
002830     02  FILLER      PICTURE X(30)   VALUE
002840         ' * AY * C *    REFERENCE     *'.
002850     02  FILLER      PICTURE X(31)   VALUE ALL '*'.
002860     02  FILLER      PICTURE X(12)   VALUE
002870         '$ I ********'.
002880     02  FILLER      PICTURE X(41)   VALUE
002890         '             REMARKS                    *'.
002900     02  FILLER          PICTURE X(18)   VALUE SPACE.
002910 01  HEAD-23.
002920     02  FILLER      PICTURE X(30)   VALUE
002930         ' * RP * T *    DESIGNATOR    *'.
002940     02  FILLER      PICTURE X(43)   VALUE
002950         '  ITEM  *  PIN *  ITEM  *  PIN $ O *   *  *'.
002960     02  FILLER      PICTURE X(40)   VALUE SPACE.
002970     02  FILLER      PICTURE X       VALUE '*'.
002980     02  FILLER          PICTURE X(18)   VALUE SPACE.
002990 01  HEAD-24.
003000     02  FILLER      PICTURE X(48)   VALUE
003010         ' * DE *3  *4                 *19      *25    *29'.
003020     02  FILLER      PICTURE X(27)   VALUE
003030         '      *35    $ D *40 *  *43'.
003040     02  FILLER      PICTURE X(38)   VALUE SPACE.
003050     02  FILLER      PICTURE X       VALUE '*'.
003060     02  FILLER          PICTURE X(18)   VALUE SPACE.
003070 01  HEAD-25.
003080     02  FILLER      PICTURE X(46)   VALUE
003090         ' *    *   *                  *        *      *'.
003100     02  FILLER      PICTURE X(27)   VALUE
003110         '        *      $   *      *'.
003120     02  FILLER      PICTURE X(40)   VALUE SPACE.
003130     02  FILLER      PICTURE X       VALUE '*'.
003140     02  FILLER          PICTURE X(18)   VALUE SPACE.
003150 01  LINE-1.
003160     02  FILLER      PICTURE X(13)   VALUE ' * B1 *   *  '.
003170     02  BOX-H1      PICTURE X(15).
003180     02  FILLER      PICTURE X(3)    VALUE ' $ '.
003190     02  CNTR-H1     PICTURE X.
003200     02  AREA-H1     PICTURE X.
003210     02  FILLER      PICTURE X(4)    VALUE ' *  '.
003220     02  DRWN-H1     PICTURE X(21).
003230     02  FILLER      PICTURE X(6)    VALUE '  *   '.
003240     02  PART-H1     PICTURE X(20).
003250     02  FILLER      PICTURE X(6)    VALUE '  *   '.
003260     02  BOXT-H1     PICTURE X(19).
003270     02  FILLER      PICTURE X(5)    VALUE '   *'.
003280     02  FILLER          PICTURE X(18)   VALUE SPACE.
003290 01  LINE-2.
003300     02  FILLER      PICTURE X(13)   VALUE ' * B2 *  *  '.
003310     02  BOX-H2      PICTURE X(15).
003320     02  FILLER      PICTURE X(3)    VALUE ' * '.
003330     02  FITM-H2     PICTURE X(6).
003340     02  FILLER      PICTURE X(3)    VALUE ' * '.
003350     02  FPIN-H2     PICTURE X(4).
003360     02  FILLER      PICTURE X(3)    VALUE ' * '.
003370     02  TITM-H2     PICTURE X(6).
003380     02  FILLER      PICTURE X(3)    VALUE ' * '.
003390     02  TPIN-H2     PICTURE X(4).
003400     02  FILLER      PICTURE X(3)    VALUE ' $ '.
003410     02  DIOD-H2     PICTURE X.
003420     02  FILLER      PICTURE X(3)    VALUE ' * '.
003430     02  IMPD-H2     PICTURE ZZ.9.
003440     02  FILLER      PICTURE X(3)    VALUE ' * '.
003450     02  RMRK-H2     PICTURE X(38).
003460     02  FILLER      PICTURE X(2)    VALUE ' *'.
003470     02  FILLER          PICTURE X(18)   VALUE SPACE.
003480 01  LINE-3.
003490     02  FILLER      PICTURE X   VALUE SPACE.
003500     02  FILLER      PICTURE X(113) VALUE ALL '*'.
003510     02  FILLER          PICTURE X(18)   VALUE SPACE.
003520 01  FOOTER.
003530     02  FILLER          PICTURE X(20)   VALUE SPACE.
003540     02  FILLER          PICTURE X(11)   VALUE 'SPACECRAFT'.
003550     02  SC-O            PICTURE X(7).
003560     02  FILLER          PICTURE X(13)   VALUE SPACE.
003570     02  FILLER      PICTURE X(12)   VALUE 'BOX NUMBER  '.
003580     02  BOX-F       PICTURE X(15).
003590     02  FILLER      PICTURE X(10)   VALUE '    DATE  '.
003600     02  DATE-F      PICTURE X(8)    VALUE SPACE.
003610     02  FILLER      PICTURE X(10)   VALUE '    PAGE  '.
003620     02  PAGE-F      PICTURE 9(3).
003630     02  FILLER      PICTURE X(4)    VALUE SPACE.
003640     02  FILLER          PICTURE X(19)   VALUE SPACE.
003650 01  THATS-ALL.
003660     02  FILLER          PICTURE X(20)   VALUE SPACE.
003670     02  FILLER          PICTURE X(15)   VALUE 'THATS ALL FOLKS'.
003680     02  FILLER          PICTURE X(97)   VALUE SPACE.
003690 PROCEDURE DIVISION.
003700     OPEN INPUT TRANS.
003710 BUILD-ARRAY.
003720     READ TRANS INTO TA AT END CLOSE TRANS  DISPLAY ' I = ' I
003730                       MOVE SPACES TO BRD-HOLD
003740                       GO TO OPEN-FILES.
003750                             NOTE -------------------------------
003760                             THIS READS THE INPUT FILE AND STORES
003770                             EACH BOX REFERENCE IN AN ARRAY TO BE
003780                             USED LATER TO CREATE A WORKING INDEX
003790                             OF THE UPDATED BOXES, AND TO
003800                             DETERMINE IF A NEW BOX, WHOSE FIRST
003810                             RECORD IS NOT UPDATED, SHOULD BE
003820                             REPORTED AS HAVING BEEN UPDATED
003830                             -----------------------------------.
003840     IF T-BRD = BRD-HOLD  GO TO BUILD-ARRAY.
003850     ADD 1 TO I.
003860     MOVE T-BRD  TO BRD-A (I).
003870     MOVE T-BRD  TO BRD-HOLD.
003880     GO TO BUILD-ARRAY.
003890 OPEN-FILES.
003900     OPEN INPUT TRANS.
003910     OPEN INPUT MASTER.
003920     OPEN OUTPUT OUT-MAST.
003930     OPEN OUTPUT ERR-REPT.
003940     OPEN OUTPUT TEMP-STOR REPRT.
003950     MOVE SPACES TO MAST-HOLD, TA, TEMP-DATA-STORAGE, M-ID-SAVE.
003960     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
003970     WRITE LINER FROM INDEX-TITLE AFTER POSITIONING 2.
003980     ADD 1 TO K.
003990 WRITE-INDEX.
004000     MOVE BRD-T (K) TO BRD-INDX.
004010                             NOTE -------------------------------
004020                             THIS CREATES A WORKING INDEX OF ALL
004030                             BOXES UPDATED
004040                             -----------------------------------.
004050     WRITE LINER FROM BRD-INDEX AFTER POSITIONING 1.
004060     ADD 1 TO K.
004070     IF K > I NEXT SENTENCE
004080         ELSE
004090             GO TO WRITE-INDEX.
004100     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
004110 READ-MASTER.
004120     READ MASTER INTO MAST-HOLD AT END GO TO MAST-END.
004130     MOVE 'M' TO ACT-CODE-M.
004140 CHECK-TYPE.
004150     IF MASTER-TYPE = 'B1' PERFORM IS-IT-REVISED THRU IIR-END.
004160 READ-TRANS.
004170     READ TRANS INTO TA AT END GO TO TRANS-END.
004180 TA-COMPR.
004190     IF T-ID LESS THAN M-ID GO TO MAST-HIGH.
004200     IF T-ID GREATER THAN M-ID GO TO MAST-LOW
004210         ELSE GO TO TA-EQUAL-MAST.
004220 IS-IT-REVISED.
004230     MOVE 1 TO J.
004240 IIR-1.
004250     IF (M-BRD = BRD-A (J))
004260             MOVE 'YES' TO TA-SW
004270             GO TO IIR-END.
004280     ADD 1 TO J.
004290     IF J GREATER THAN I MOVE ' NO' TO TA-SW
004300                         GO TO IIR-END.
004310     GO TO IIR-1.
004320 IIR-END.
004330     EXIT.
004340 MAST-HIGH.
004350     IF ACTION-CODE = 'I' NEXT SENTENCE
004360         ELSE MOVE '1' TO ERR-LOC
004370             PERFORM ERROR-I
004380             GO TO READ-TRANS.
004390                             NOTE -------------------------------
004400                             THIS IS REACHED WHEN A RECORD IS TO
004410                             BE ADDED TO THE MASTER FILE
004420                             -----------------------------------.
004430     IF TA-TYPE = 'B1' PERFORM  TA-B1-I
004440         ELSE    PERFORM TA-B2-I.
004450     WRITE INT-STOR  FROM TEMP-DATA-STORAGE.
004460     WRITE NEW-MAST  FROM TEMP-DATA-STORAGE.
004470     MOVE SPACES TO TEMP-DATA-STORAGE.
004480     GO TO READ-TRANS.
004490 MAST-LOW.
004500     IF TA-SW = 'YES' WRITE INT-STOR FROM MAST-HOLD.
004510                             NOTE -------------------------------
004520                             THIS IS REACHED WHEN THERE IS NO
004530                             TRANSACTIONS AGAINST THIS PORTION
004540                             OF THE MASTER FILE
004550                             -----------------------------------.
004560     WRITE NEW-MAST FROM MAST-HOLD.
004570         MOVE M-BRD TO BRD-SAVE
004580     MOVE SPACES TO MAST-HOLD.
004590     READ MASTER INTO MAST-HOLD AT END GO TO MAST-END.
004600     MOVE 'M' TO ACT-CODE-M.
004610     IF MASTER-TYPE = 'B1' PERFORM IS-IT-REVISED THRU IIR-END.
004620     GO TO TA-COMPR.
004630 MAST-END.
004640     IF ACTION-CODE = 'I' NEXT SENTENCE
004650         ELSE MOVE '2' TO ERR-LOC
004660             PERFORM ERROR-I
004670             READ TRANS INTO TA AT END GO TO THE-END
004680             GO TO MAST-END.
004690     IF TA-TYPE = 'B1'  MOVE T-BRD TO BRD-SAVE
004700             GO TO M-E-1.
004710     IF TA-TYPE = 'B2' AND T-BRD = BRD-SAVE NEXT SENTENCE
004720         ELSE
004730             DISPLAY ' NO B1 RECORD ' TA
004740             READ TRANS INTO TA AT END GO TO THE-END
004750             GO TO MAST-END.
004760 M-E-1.
004770     PERFORM TA-TO-OUTPUT-AREA.
004780     WRITE NEW-MAST FROM TEMP-DATA-STORAGE.
004790     WRITE INT-STOR FROM TEMP-DATA-STORAGE.
004800     MOVE SPACE TO TEMP-DATA-STORAGE.
004810     READ TRANS INTO TA AT END GO TO THE-END.
004820     GO TO MAST-END.
004830 TRANS-END.
004840     IF TA-SW = 'YES' WRITE INT-STOR FROM MAST-HOLD.
004850     WRITE NEW-MAST FROM MAST-HOLD.
004860     MOVE SPACES TO MAST-HOLD.
004870     READ MASTER INTO MAST-HOLD AT END GO TO THE-END.
004880     MOVE 'M' TO ACT-CODE-M.
004890     IF MASTER-TYPE = 'B1' PERFORM IS-IT-REVISED THRU IIR-END.
004900     GO TO TRANS-END.
004910 TA-B1-I.
004920     MOVE SPACES TO TEMP-DATA-STORAGE.
004930     MOVE TA-TYPE    TO  TYPE-I.
004940     MOVE ACTION-CODE TO ACT-I.
004950     MOVE T-ID       TO  ID-I.
004960     MOVE B1-REST-T  TO  B1-REST-I.
004970 TA-B2-I.
004980     MOVE SPACES TO TEMP-DATA-STORAGE.
004990     MOVE TA-TYPE    TO  TYPE-I.
005000     MOVE ACTION-CODE TO ACT-I.
005010     MOVE T-ID       TO  ID-I.
005020     MOVE B2-REST-T  TO  B2-REST-I.
005030 TA-TO-OUTPUT-AREA.
005040     MOVE SPACES TO TEMP-DATA-STORAGE.
005050     MOVE TA-TYPE    TO  TYPE-I.
005060     MOVE ACTION-CODE TO ACT-I.
005070     MOVE T-ID       TO  ID-I.
005080     MOVE B1-REST-T  TO  B1-REST-I.
005090 TA-EQUAL-MAST.
005100     IF TA-TYPE = 'B1' GO TO CHECK-ACTION-CODE.
005110                             NOTE -------------------------------
005120                             THIS IS REACHED ONLY FOR REVISIONS
005130                             OR DELETIONS
005140                             -----------------------------------.
005150     IF TA-TYPE = 'B2' NEXT SENTENCE
005160          ELSE MOVE '3' TO ERR-LOC
005170               PERFORM  ERROR-B1-B2
005180               GO TO READ-TRANS.
005190     IF ACTION-CODE = 'D' GO TO READ-MASTER.
005200     IF ACTION-CODE = 'R' NEXT SENTENCE
005210          ELSE MOVE '4' TO ERR-LOC
005220               PERFORM  ERROR-R-D
005230               GO TO READ-TRANS.
005240     PERFORM REVISE-B2 THRU REVISE-B2-END.
005250     WRITE NEW-MAST FROM MAST-HOLD.
005260     WRITE INT-STOR FROM MAST-HOLD.
005270         MOVE M-BRD TO BRD-SAVE
005280     MOVE SPACES TO MAST-HOLD.
005290     GO TO READ-NEXT-TA.
005300 CHECK-ACTION-CODE.
005310     IF ACTION-CODE = 'D' GO TO ACT-CODE-D.
005320     IF ACTION-CODE = 'R' NEXT SENTENCE
005330         ELSE MOVE '5' TO ERR-LOC
005340              PERFORM ERROR-R-D
005350              GO TO READ-TRANS.
005360     PERFORM REVISE-B1 THRU REVISE-B1-END.
005370     WRITE NEW-MAST FROM MAST-HOLD.
005380     WRITE INT-STOR FROM MAST-HOLD.
005390         MOVE M-BRD TO BRD-SAVE
005400     MOVE SPACES TO MAST-HOLD.
005410 READ-NEXT-TA.
005420     READ TRANS INTO TA AT END GO TO TRANS-END.
005430     IF M-BRD = T-BRD GO TO M-BRD-EQ-T-BRD.
005440     MOVE M-ID TO M-ID-SAVE.
005450 READ-NEXT-MASTER.
005460     READ MASTER INTO MAST-HOLD AT END GO TO MAST-END.
005470     MOVE 'M' TO ACT-CODE-M.
005480     IF M-BRD = M-BRD-SAVE
005490          WRITE INT-STOR FROM MAST-HOLD
005500          WRITE NEW-MAST FROM MAST-HOLD
005510         MOVE M-BRD TO BRD-SAVE
005520          MOVE SPACES TO MAST-HOLD
005530          GO TO READ-NEXT-MASTER.
005540     IF MASTER-TYPE = 'B1' PERFORM IS-IT-REVISED THRU IIR-END.
005550     GO TO TA-COMPR.
005560 M-BRD-EQ-T-BRD.
005570         MOVE M-BRD TO BRD-SAVE
005580     READ MASTER INTO MAST-HOLD AT END GO TO MAST-END.
005590     MOVE 'M' TO ACT-CODE-M.
005600 CHECK-M-ID-T-ID.
005610     IF M-ID LESS THAN T-ID
005620         WRITE INT-STOR FROM MAST-HOLD
005630         WRITE NEW-MAST FROM MAST-HOLD
005640         MOVE M-BRD TO BRD-SAVE
005650         MOVE SPACES TO MAST-HOLD
005660         GO TO M-BRD-EQ-T-BRD.
005670     IF M-ID = T-ID GO TO M-ID-EQ-T-ID.
005680     IF ACTION-CODE = 'I'
005690                 PERFORM TA-TO-OUTPUT-AREA
005700                 WRITE NEW-MAST FROM TEMP-DATA-STORAGE
005710                 WRITE INT-STOR FROM TEMP-DATA-STORAGE
005720                 MOVE SPACES TO TEMP-DATA-STORAGE
005730         ELSE
005740                 MOVE '6' TO ERR-LOC
005750                 PERFORM ERROR-I.
005760 READ-ANOTHER-TA.
005770     READ TRANS INTO TA AT END GO TO TRANS-END.
005780     IF M-BRD = T-BRD GO TO CHECK-M-ID-T-ID.
005790     MOVE M-ID TO M-ID-SAVE.
005800     WRITE INT-STOR FROM MAST-HOLD
005810     WRITE NEW-MAST FROM MAST-HOLD
005820         MOVE M-BRD TO BRD-SAVE
005830     GO TO READ-NEXT-MASTER.
005840 M-ID-EQ-T-ID.
005850     IF ACTION-CODE = 'D' GO TO READ-NEXT-TA.
005860     IF ACTION-CODE = 'R'
005870                 PERFORM REVISE-B2 THRU REVISE-B2-END
005880                 WRITE INT-STOR FROM MAST-HOLD
005890                 WRITE NEW-MAST FROM MAST-HOLD
005900         MOVE M-BRD TO BRD-SAVE
005910                 MOVE SPACES TO MAST-HOLD
005920                 GO TO READ-NEXT-TA
005930         ELSE
005940                 MOVE '7' TO ERR-LOC
005950                 PERFORM ERROR-R-D
005960                 GO TO READ-ANOTHER-TA.
005970 ACT-CODE-D.
005980     MOVE B1-DELETE TO B1-REST-M.
005990 WRITE-DELETED.
006000     WRITE INT-STOR FROM MAST-HOLD.
006010     MOVE M-ID TO M-ID-SAVE.
006020         MOVE M-BRD TO BRD-SAVE
006030     MOVE SPACES TO MAST-HOLD.
006040     READ MASTER INTO MAST-HOLD AT END GO TO MAST-END.
006050     MOVE 'M' TO ACT-CODE-M.
006060     IF M-BRD = M-BRD-SAVE
006070                 MOVE B2-DELETE  TO B2-REST-M
006080                 GO TO WRITE-DELETED.
006090     GO TO CHECK-TYPE.
006100 REVISE-B1.
006110     IF CNTR-T = '@' MOVE SPACE TO CNTR-M GO TO CK-AREA.
006120                             NOTE -------------------------------
006130                             THIS ACTUALLY UPDATES A B1-RECORD
006140                             -----------------------------------.
006150     IF CNTR-T = SPACE NEXT SENTENCE
006160         ELSE MOVE CNTR-T TO CNTR-M.
006170 CK-AREA.
006180     IF AREA-T = '@' MOVE SPACE TO AREA-M GO TO CK-DRAW.
006190     IF AREA-T = SPACE NEXT SENTENCE
006200         ELSE MOVE AREA-T TO AREA-M.
006210 CK-DRAW.
006220     IF DRAW-NO-TX = '@' MOVE SPACE TO DRAW-NO-M GO TO CK-UNIT.
006230     IF DRAW-NO-T = SPACE NEXT SENTENCE
006240         ELSE MOVE DRAW-NO-T TO DRAW-NO-M.
006250 CK-UNIT.
006260     IF UNIT-PART-X = '@' MOVE SPACE TO UNIT-PART-M GO TO CK-BOX.
006270     IF UNIT-PART-T = SPACE NEXT SENTENCE
006280         ELSE MOVE UNIT-PART-T TO UNIT-PART-M.
006290 CK-BOX.
006300     IF BOX-TITLE-X = '@' MOVE SPACE TO BOX-TITLE-M
006310                                     GO TO REVISE-B1-END.
006320     IF BOX-TITLE-T = SPACE NEXT SENTENCE
006330         ELSE MOVE BOX-TITLE-T TO BOX-TITLE-M.
006340 REVISE-B1-END.
006350     EXIT.
006360 REVISE-B2.
006370     IF DIOD-T = '@' MOVE SPACE TO DIOD-M GO TO CK-IMP.
006380                             NOTE -------------------------------
006390                             THIS ACTUALLY UPDATES A B2-RECORD
006400                             -----------------------------------.
006410     IF DIOD-T = SPACE NEXT SENTENCE
006420         ELSE MOVE DIOD-T TO DIOD-M.
006430 CK-IMP.
006440     IF IMP-TX = '@' MOVE ZERO  TO IMP-M GO TO CK-RMKS.
006450     IF IMP-T = SPACE NEXT SENTENCE
006460         ELSE MOVE IMP-T1 TO IMP-M.
006470 CK-RMKS.
006480     IF REMARKS-TX = '@' MOVE SPACE TO REMARKS-M
006490                             GO TO REVISE-B2-END.
006500     IF REMARKS-T = SPACE NEXT SENTENCE
006510         ELSE MOVE REMARKS-T TO REMARKS-M.
006520 REVISE-B2-END.
006530     EXIT.
006540 ERROR-I.
006550     MOVE SPACE TO BAD-RKD.
006560     MOVE TA TO BAD-RKD.
006570     WRITE ELINE FROM ASTR AFTER POSITIONING 2.
006580     WRITE ELINE FROM ERR2 AFTER POSITIONING 1.
006590     WRITE ELINE FROM ERR8 AFTER POSITIONING 1.
006600 ERROR-B1-B2.
006610     MOVE SPACE TO BAD-RKD.
006620     MOVE TA TO BAD-RKD.
006630     WRITE ELINE FROM ASTR AFTER POSITIONING 2.
006640     WRITE ELINE FROM ERR5 AFTER POSITIONING 1.
006650     WRITE ELINE FROM ERR8 AFTER POSITIONING 1.
006660 ERROR-R-D.
006670     MOVE SPACE TO BAD-RKD.
006680     MOVE TA TO BAD-RKD.
006690     WRITE ELINE FROM ASTR AFTER POSITIONING 2.
006700     WRITE ELINE FROM ERR6  AFTER POSITIONING 1.
006710     WRITE ELINE FROM ERR8 AFTER POSITIONING 1.
006720 THE-END.
006730     CLOSE TRANS.
006740     CLOSE MASTER.
006750     CLOSE OUT-MAST.
006760     CLOSE TEMP-STOR.
006770     DISPLAY ' '.
006780     DISPLAY 'MASTER FILE UPDATE COMPLETED'.
006790     DISPLAY ' '.
006800 REPORT-REVISIONS.
006810     OPEN INPUT TEMP-STOR   CARDIN.
006820                             NOTE -------------------------------
006830                             THIS REPORTS COMPLETELY ANY BOX
006840                             WHICH HAS BEEN ADDED, REVISED, OR
006850                             DELETED DURING THIS UPDATE
006860                             -----------------------------------.
006870     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
006880     READ CARDIN AT END DISPLAY 'NO DATE CARD FOR THIS RUN'
006890                                     GO TO READ-TEMP-STOR.
006900     MOVE REPT-DATE  TO DATE-F.
006910 READ-TEMP-STOR.
006920     MOVE SPACES TO MAST-HOLD.
006930     READ TEMP-STOR INTO MAST-HOLD AT END GO TO TEMP-END.
006940     IF MASTER-TYPE = 'B1' NEXT SENTENCE
006950         ELSE  DISPLAY 'NO B1 RECORD ' MAST-HOLD
006960               GO TO READ-TEMP-STOR.
006970 MOVE-IT-1.
006980     IF CNTR-M = 'N' MOVE CSM-I TO SC-O  ELSE MOVE LM-I TO SC-O.
006990     MOVE 1 TO PAGE-F.
007000     MOVE M-BRD    TO    BOX-H1  BOX-F.
007010     MOVE CNTR-M       TO  CNTR-H1.
007020     MOVE AREA-M       TO  AREA-H1.
007030     MOVE DRAW-NO-M    TO  DRWN-H1.
007040     MOVE UNIT-PART-M  TO  PART-H1.
007050     MOVE BOX-TITLE-M  TO  BOXT-H1.
007060 WRITE-FRST-PAGE-HEADR.
007070     WRITE LINER FROM LINE-3     AFTER POSITIONING 0.
007080     WRITE LINER FROM HEAD-11    AFTER POSITIONING 1.
007090     WRITE LINER FROM HEAD-12    AFTER POSITIONING 1.
007100     WRITE LINER FROM HEAD-13    AFTER POSITIONING 1.
007110     WRITE LINER FROM HEAD-14    AFTER POSITIONING 1.
007120     WRITE LINER FROM LINE-3     AFTER POSITIONING 1.
007130     WRITE LINER FROM HEAD-15    AFTER POSITIONING 1.
007140     WRITE LINER FROM LINE-1     AFTER POSITIONING 1.
007150     WRITE LINER FROM HEAD-15    AFTER POSITIONING 1.
007160     WRITE LINER FROM LINE-3     AFTER POSITIONING 1.
007170     WRITE LINER FROM HEAD-21    AFTER POSITIONING 1.
007180     WRITE LINER FROM HEAD-22    AFTER POSITIONING 1.
007190     WRITE LINER FROM HEAD-23    AFTER POSITIONING 1.
007200     WRITE LINER FROM HEAD-24    AFTER POSITIONING 1.
007210     WRITE LINER FROM LINE-3     AFTER POSITIONING 1.
007220     MOVE 16 TO LNE-CNT.
007230 NEXT-READ.
007240     MOVE M-ID TO M-ID-SAVE.
007250     MOVE SPACES TO MAST-HOLD
007260     READ TEMP-STOR INTO MAST-HOLD AT END GO TO TEMP-END.
007270     IF ((MASTER-TYPE = 'B2') AND (M-BRD = M-BRD-SAVE))
007280                                 GO TO MOVE-IT-2.
007290     IF MASTER-TYPE = 'B1' PERFORM PAGE-BOTTOM GO TO MOVE-IT-1.
007300     DISPLAY 'NO B1 RECORD ' MAST-HOLD.
007310     IF M-BRD = M-BRD-SAVE GO TO NEXT-READ
007320             ELSE  PERFORM PAGE-BOTTOM
007330                   GO TO READ-TEMP-STOR.
007340 MOVE-IT-2.
007350     MOVE M-BRD  TO  BOX-H2.
007360     MOVE FROM-I TO  FITM-H2.
007370     MOVE FROM-P TO  FPIN-H2.
007380     MOVE TO-I   TO  TITM-H2.
007390     MOVE TO-P   TO  TPIN-H2.
007400     MOVE DIOD-M TO  DIOD-H2.
007410     MOVE IMP-M  TO  IMPD-H2.
007420     MOVE REMARKS-M TO RMRK-H2.
007430     IF LNE-CNT < 60  PERFORM B2-WRITE GO TO NEXT-READ.
007440     PERFORM PAGE-BOTTOM.
007450     PERFORM WRITE-HEADER3.
007460     PERFORM B2-WRITE.
007470     GO TO NEXT-READ.
007480 PAGE-BOTTOM.
007490     WRITE LINER FROM LINE-3 AFTER POSITIONING 1.
007500     WRITE LINER FROM FOOTER AFTER POSITIONING 2.
007510 WRITE-HEADER3.
007520     WRITE LINER FROM LINE-3     AFTER POSITIONING 0.
007530     WRITE LINER FROM HEAD-21    AFTER POSITIONING 1.
007540     WRITE LINER FROM HEAD-22    AFTER POSITIONING 1.
007550     WRITE LINER FROM HEAD-23    AFTER POSITIONING 1.
007560     WRITE LINER FROM HEAD-24    AFTER POSITIONING 1.
007570     WRITE LINER FROM LINE-3     AFTER POSITIONING 1.
007580     MOVE  7  TO LNE-CNT ADD 1 TO PAGE-F.
007590 B2-WRITE.
007600     WRITE LINER FROM HEAD-25    AFTER POSITIONING 1.
007610     WRITE LINER FROM LINE-2 AFTER POSITIONING 1 ADD 2 TO LNE-CNT.
007620 TEMP-END.
007630     PERFORM PAGE-BOTTOM.
007640     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
007650     WRITE LINER FROM THATS-ALL  AFTER POSITIONING 1.
007660     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
007670     CLOSE TEMP-STOR.
007680     CLOSE CARDIN.
007690     CLOSE REPRT.
007700     OPEN OUTPUT PURE-MAST.
007710     OPEN INPUT OUT-MAST.
007720     OPEN OUTPUT INDEX-TABL.
007730     WRITE ELINE FROM BLANK-LINE AFTER POSITIONING 0.
007740     WRITE ELINE FROM B2-WO-B1 AFTER POSITIONING 3.
007750     WRITE ELINE FROM BLANK-LINE AFTER POSITIONING 2.
007760 PURIFY-MASTER.
007770     READ OUT-MAST INTO MAST-HOLD AT END GO TO STOP-IT.
007780                             NOTE -------------------------------
007790                             THIS CHECKS FOR AND DELETES ALL
007800                             B2-RECORDS WHICH EXIST ON THE
007810                             MASTER FILE WITHOUT A CORRESPONDING
007820                             B1-RECORD
007830                             -----------------------------------.
007840     IF MASTER-TYPE = 'B1' OR M-BRD = B1-M-BRD-SAVE
007850                 WRITE NMF FROM MAST-HOLD
007860                 MOVE M-BRD TO B1-M-BRD-SAVE
007870                 ADD 1 TO G-REC-CNTR
007880         ELSE
007890                 MOVE MAST-HOLD TO M-DELETE
007900                 WRITE ELINE FROM M-DELETED AFTER POSITIONING 1.
007910     IF MASTER-TYPE = 'B1' MOVE M-BRD TO BRD-INDX
007920                           WRITE INDX FROM BRD-INDEX.
007930     GO TO PURIFY-MASTER.
007940 STOP-IT.
007950     CLOSE OUT-MAST.
007960     CLOSE INDEX-TABL.
007970     OPEN INPUT INDEX-TABL.
007980     WRITE ELINE FROM BLANK-LINE AFTER POSITIONING 0.
007990     WRITE ELINE FROM INDEX-TITLE AFTER POSITIONING 3.
008000     WRITE ELINE FROM BLANK-LINE AFTER POSITIONING 2.
008010 RPT-N-INDX.
008020     READ INDEX-TABL AT END GO TO THATS-IT.
008030     WRITE ELINE FROM INDX AFTER POSITIONING 1.
008040     GO TO RPT-N-INDX.
008050 THATS-IT.
008060     CLOSE INDEX-TABL.
008070     CLOSE ERR-REPT.
008080     DISPLAY  'RECORDS ON MASTER FILE ' G-REC-CNTR.
008090     CLOSE PURE-MAST.
008100     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.         'BIDRPT'.
000030 AUTHOR.             JESSE VAWTER.
000040 DATE-WRITTEN.       JANUARY 17,1968.
000050 REMARKS.
000060     THIS PROGRAM EXPECTS A 100-CHARACTER BID MASTER FILE AS
000070     INPUT PLUS AN INPUT OPTION CARD,
000080     THIS PROGRAM OUTPUTS, ON OPTION, A FORMATTED REPORT
000090     AND/OR A 149-CHARACTER TAPE WHICH IS PASSED TO THE
000100     BID-BED MERGE.
000110 ENVIRONMENT DIVISION.
000120 CONFIGURATION SECTION.
000130 SOURCE-COMPUTER.    IBM-360.
000140 OBJECT-COMPUTER.    IBM-360.
000150 INPUT-OUTPUT SECTION.
000160 FILE-CONTROL.
000170     SELECT UPDTAPE ASSIGN TO UT-S-UPDT.
000180     SELECT RPRTAPE ASSIGN TO UT-S-RPTT.
000190     SELECT MASTAPE ASSIGN TO UT-S-MAST.
000200     SELECT OPT-CARD ASSIGN TO UT-S-OPT.
000210     SELECT INDEX-LIST  ASSIGN TO UT-S-INDX.
000220 DATA DIVISION.
000230 FILE SECTION.
000240 FD  INDEX-LIST
000250     RECORDING MODE IS F
000260     BLOCK CONTAINS 1 RECORDS
000270     LABEL RECORDS ARE OMITTED
000280     DATA RECORD IS INDEXR.
000290 01  INDEXR.
000300     02  FILLER      PICTURE X(132).
000310 FD  UPDTAPE
000320     RECORDING MODE IS F
000330     BLOCK CONTAINS 10 RECORDS
000340     LABEL RECORDS ARE OMITTED
000350     DATA RECORD IS EDTP.
000360 01  EDTP            PICTURE X(100).
000370 FD  RPRTAPE
000380     LABEL RECORDS ARE OMITTED
000390     RECORDING MODE IS F
000400     BLOCK CONTAINS 7 RECORDS
000410     DATA RECORD IS RPT.
000420 01  RPT             PICTURE X(132).
000430 FD  MASTAPE
000440     RECORDING MODE IS F
000450     BLOCK CONTAINS  10  RECORDS
000460     LABEL RECORDS ARE OMITTED
000470     DATA RECORD IS ASP-TAPE.
000480 01  ASP-TAPE        PICTURE X(149).
000490 FD  OPT-CARD
000500     RECORDING MODE IS F
000510     BLOCK CONTAINS 1 RECORDS
000520     LABEL RECORDS ARE OMITTED
000530     DATA RECORD IS OPTION-CARD.
000540 01  OPTION-CARD.
000550     02  REPORT-OPTION       PICTURE X(3).
000560     02  TAPE149-OPTION      PICTURE X(3).
000570     02  DUM1                PICTURE X(2).
000580     02  DUM2                PICTURE X(2).
000590     02  DUM3                PICTURE X(2).
000600     02  DUM4                PICTURE X(2).
000610     02  DUM5                PICTURE X(2).
000620     02  DUM6                PICTURE X(2).
000630     02  DUM7                PICTURE X(2).
000640     02  DUM8                PICTURE X(2).
000650     02  DUM9                PICTURE X(2).
000660     02  DATE-ON-REPT        PICTURE X(8).
000670     02  FILLER              PICTURE X(08).
000680     02  CSM-I           PICTURE X(7).
000690     02  FILLER          PICTURE X(03).
000700     02  LM-I            PICTURE X(7).
000710     02  FILLER          PICTURE X(23).
000720 WORKING-STORAGE SECTION.
000730 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000740 77  NO-IN-REC           PICTURE 9(6)  VALUE  ZERO.
000750 77  NO-OU-REC           PICTURE 9(6)  VALUE ZERO.
000760 77  TAPE-SWITCH      PICTURE X(3)     VALUE SPACE.
000770 77  LNE-CNT       PICTURE 99    VALUE ZERO.
000780 77  CNTR            PICTURE 99.
000790 01  B1-SAVE.
000800     02  FILLER          PICTURE X(38).
000810     02  CA-SAV          PICTURE XX.
000820     02  DRWGNO-SAV.
000830             03  GSE-BAY     PICTURE X(3).
000840             03  GSE-DRAWING PICTURE X(18).
000850         02  FILLER      PICTURE X(39).
000860 01  T-CA-M-SAV.
000870     02  T-C-M-SAV       PICTURE X   VALUE SPACE.
000880     02  T-A-M-SAV       PICTURE X   VALUE SPACE.
000890 01  F-CA-M-SAV.
000900     02  F-C-M-SAV       PICTURE X   VALUE SPACE.
000910     02  F-A-M-SAV       PICTURE X   VALUE SPACE.
000920 01  HDR.
000930     02  FILLER      PICTURE X(10)   VALUE SPACE.
000940     02  FILLER      PICTURE X(24)
000950             VALUE 'BOX REFERENCE DESIGNATOR'.
000960     02  FILLER      PICTURE X(98)   VALUE SPACE.
000970 01  LINER-4.
000980     02  FILLER      PICTURE X(10)   VALUE SPACE.
000990     02  BOX-H4      PICTURE X(15).
001000     02  FILLER      PICTURE X(107)  VALUE SPACE.
001010 01  UPDT-HOLD.
001020     02  CONT.
001030      03 CRDTP       PICTURE XX.
001040      03 FILLER    PICTURE X.
001050      03 BOXRF       PICTURE X(15).
001060     02  ED-DAT1.
001070      03 FILLER      PICTURE X(20).
001080      03  CA.
001090       04   CNTRCD      PICTURE X.
001100       04   AREACD      PICTURE X.
001110      03 DRWGNO      PICTURE X(21).
001120      03 PARTNO      PICTURE X(20).
001130      03 BOXTTL      PICTURE X(19).
001140     02  ED-DAT2 REDEFINES ED-DAT1.
001150      03 F-CONN.
001160       04 F-ITEM     PICTURE X(6).
001170       04 TYPE-CHK REDEFINES F-ITEM.
001180        05 FILLER    PICTURE X(6).
001190       04 F-PIN      PICTURE X(4).
001200      03 T-CONN.
001210       04 T-ITEM     PICTURE X(6).
001220        04 TYP-CHK2 REDEFINES T-ITEM.
001230         05 FILLER   PICTURE X(6).
001240       04 T-PIN      PICTURE X(4).
001250      03 DIODE       PICTURE X.
001260      03 IMPED       PICTURE 99V9.
001270      03 RMRKS       PICTURE X(38).
001280      03 FILLER      PICTURE X(20).
001290 01  BLD-REC.
001300     02  FILLER      PICTURE X(4) VALUE SPACE.
001310     02  TYP-REC     PICTURE X(3).
001320     02  FILLER      PICTURE X(9) VALUE SPACE.
001330 01  BLD-REC2.
001340     02  FILLER      PICTURE X(3) VALUE SPACE.
001350     02  TYP-REC2    PICTURE X(3).
001360     02  FILLER      PICTURE X(10) VALUE SPACE.
001370 01  MAST-REC.
001380     02  BOXRF-M     PICTURE X(15).
001390     02  FCONN-M.
001400      03 F-CA-M.
001410        04 FCONT-M     PICTURE X.
001420        04 FAREA-M     PICTURE X.
001430      03 FITEM-M     PICTURE X(6).
001440         03  CHK-TYP1 REDEFINES FITEM-M.
001450             04  TYP1            PICTURE X(3).
001460             04  FILLER          PICTURE X(3).
001470      03 TYP1-FOLLOW.
001480       04  BAY-F         PICTURE X(3).
001490       04  FILLER        PICTURE X  VALUE SPACE.
001500       04 F-PIN-M     PICTURE X(4).
001510     02  TCONN-M.
001520      03 T-CA-M.
001530        04 TCONT-M     PICTURE X.
001540        04 TAREA-M     PICTURE X.
001550      03 TITEM-M     PICTURE X(6).
001560         03 CHK-TYP2 REDEFINES TITEM-M.
001570             04  TYP2            PICTURE X(3).
001580             04  FILLER          PICTURE X(3).
001590      03  TYPE2-FOLLOW.
001600       04  BAY-T         PICTURE X(3).
001610       04  FILLER        PICTURE X  VALUE SPACE.
001620       04 T-PIN-M     PICTURE X(4).
001630     02  DIODE-M     PICTURE X.
001640     02  IMPED-M     PICTURE 99V9.
001650     02  DRWNO-M     PICTURE X(21).
001660     02  PRTNO-M     PICTURE X(20).
001670     02  BXTTL-M     PICTURE X(19).
001680     02  RMRKS-M.
001690         03  FILLER     PICTURE X(29).
001700         03 FILLER         PICTURE X(8)  VALUE SPACE.
001710         03  DUP        PICTURE X     VALUE SPACE.
001720 01  HEAD-11.
001730     02  FILLER      PICTURE X(35)   VALUE
001740         ' * CT * A *                  $ CA *'.
001750     02  FILLER      PICTURE X(25)   VALUE SPACE.
001760     02  FILLER      PICTURE X       VALUE '*'.
001770     02  FILLER      PICTURE X(25)   VALUE SPACE.
001780     02  FILLER      PICTURE X       VALUE '*'.
001790     02  FILLER      PICTURE X(26)   VALUE SPACE.
001800     02  FILLER      PICTURE X       VALUE '*'.
001810     02  FILLER          PICTURE X(18)   VALUE SPACE.
001820 01  HEAD-12.
001830     02  FILLER      PICTURE X(35)   VALUE
001840         ' * AY * C *       BOX        $ NR *'.
001850     02  FILLER      PICTURE X(25)   VALUE SPACE.
001860     02  FILLER      PICTURE X       VALUE '*'.
001870     02  FILLER      PICTURE X(25)   VALUE SPACE.
001880     02  FILLER      PICTURE X       VALUE '*'.
001890     02  FILLER      PICTURE X(26)   VALUE SPACE.
001900     02  FILLER      PICTURE X       VALUE '*'.
001910     02  FILLER          PICTURE X(18)   VALUE SPACE.
001920 01  HEAD-13.
001930     02  FILLER      PICTURE X(35)   VALUE
001940         ' * RP * T *    REFERENCE     $ TE *'.
001950     02  FILLER      PICTURE X(52)   VALUE
001960         '     DRAWING NUMBER      *     UNIT PART NUMBER   *'.
001970     02  FILLER      PICTURE X(27)   VALUE
001980         '        BOX TITLE         *'.
001990     02  FILLER          PICTURE X(18)   VALUE SPACE.
002000 01  HEAD-14.
002010     02  FILLER      PICTURE X(37)   VALUE
002020         ' * DE *3  *4   DESIGNATOR  18$ RA *21'.
002030     02  FILLER      PICTURE X(23)   VALUE SPACE.
002040     02  FILLER      PICTURE X(3)    VALUE '*42'.
002050     02  FILLER      PICTURE X(23)   VALUE SPACE.
002060     02  FILLER      PICTURE X(3)    VALUE '*62'.
002070     02  FILLER      PICTURE X(24)   VALUE SPACE.
002080     02  FILLER      PICTURE X       VALUE '*'.
002090     02  FILLER          PICTURE X(18)   VALUE SPACE.
002100 01  HEAD-15.
002110     02  FILLER      PICTURE X(35)   VALUE
002120         ' *    *   *                  $    *'.
002130     02  FILLER      PICTURE X(25)   VALUE SPACE.
002140     02  FILLER      PICTURE X       VALUE '*'.
002150     02  FILLER      PICTURE X(25)   VALUE SPACE.
002160     02  FILLER      PICTURE X       VALUE '*'.
002170     02  FILLER      PICTURE X(26)   VALUE SPACE.
002180     02  FILLER      PICTURE X       VALUE '*'.
002190     02  FILLER          PICTURE X(18)   VALUE SPACE.
002200 01  HEAD-21.
002210     02  FILLER      PICTURE X(54)   VALUE
002220         ' * CT * A *       BOX        *     FROM      *      TO'.
002230     02  FILLER      PICTURE X(19)   VALUE
002240         '       $ D *  IMP *'.
002250     02  FILLER      PICTURE X(40)   VALUE SPACE.
002260     02  FILLER      PICTURE X       VALUE '*'.
002270     02  FILLER          PICTURE X(18)   VALUE SPACE.
002280 01  HEAD-22.
002290     02  FILLER      PICTURE X(30)   VALUE
002300         ' * AY * C *    REFERENCE     *'.
002310     02  FILLER      PICTURE X(31)   VALUE ALL '*'.
002320     02  FILLER      PICTURE X(12)   VALUE
002330         '$ I ********'.
002340     02  FILLER      PICTURE X(41)   VALUE
002350         '             REMARKS                    *'.
002360     02  FILLER          PICTURE X(18)   VALUE SPACE.
002370 01  HEAD-23.
002380     02  FILLER      PICTURE X(30)   VALUE
002390         ' * RP * T *    DESIGNATOR    *'.
002400     02  FILLER      PICTURE X(43)   VALUE
002410         '  ITEM  *  PIN *  ITEM  *  PIN $ O *   *  *'.
002420     02  FILLER      PICTURE X(40)   VALUE SPACE.
002430     02  FILLER      PICTURE X       VALUE '*'.
002440     02  FILLER          PICTURE X(18)   VALUE SPACE.
002450 01  HEAD-24.
002460     02  FILLER      PICTURE X(48)   VALUE
002470         ' * DE *3  *4                 *19      *25    *29'.
002480     02  FILLER      PICTURE X(27)   VALUE
002490         '      *35    $ D *40 *  *43'.
002500     02  FILLER      PICTURE X(38)   VALUE SPACE.
002510     02  FILLER      PICTURE X       VALUE '*'.
002520     02  FILLER          PICTURE X(18)   VALUE SPACE.
002530 01  HEAD-25.
002540     02  FILLER      PICTURE X(46)   VALUE
002550         ' *    *   *                  *        *      *'.
002560     02  FILLER      PICTURE X(27)   VALUE
002570         '        *      $   *      *'.
002580     02  FILLER      PICTURE X(40)   VALUE SPACE.
002590     02  FILLER      PICTURE X       VALUE '*'.
002600     02  FILLER          PICTURE X(18)   VALUE SPACE.
002610 01  LINE-1.
002620     02  FILLER      PICTURE X(13)   VALUE ' * B1 *   *  '.
002630     02  BOX-H1      PICTURE X(15).
002640     02  FILLER      PICTURE X(3)    VALUE ' $ '.
002650     02  CNTR-H1     PICTURE X.
002660     02  AREA-H1     PICTURE X.
002670     02  FILLER      PICTURE X(4)    VALUE ' *  '.
002680     02  DRWN-H1     PICTURE X(21).
002690     02  FILLER      PICTURE X(6)    VALUE '  *   '.
002700     02  PART-H1     PICTURE X(20).
002710     02  FILLER      PICTURE X(6)    VALUE '  *   '.
002720     02  BOXT-H1     PICTURE X(19).
002730     02  FILLER      PICTURE X(5)    VALUE '    *'.
002740     02  FILLER          PICTURE X(18)   VALUE SPACE.
002750 01  LINE-2.
002760     02  FILLER      PICTURE X(13)   VALUE ' * B2 *   *  '.
002770     02  BOX-H2      PICTURE X(15).
002780     02  FILLER      PICTURE X(3)    VALUE ' * '.
002790     02  FITM-H2     PICTURE X(6).
002800     02  FILLER      PICTURE X(3)    VALUE ' * '.
002810     02  FPIN-H2     PICTURE X(4).
002820     02  FILLER      PICTURE X(3)    VALUE ' * '.
002830     02  TITM-H2     PICTURE X(6).
002840     02  FILLER      PICTURE X(3)    VALUE ' * '.
002850     02  TPIN-H2     PICTURE X(4).
002860     02  FILLER      PICTURE X(3)    VALUE ' $ '.
002870     02  DIOD-H2     PICTURE X.
002880     02  FILLER      PICTURE X(3)    VALUE ' * '.
002890     02  IMPD-H2     PICTURE ZZ.9.
002900     02  FILLER      PICTURE X(3)    VALUE ' * '.
002910     02  RMRK-H2     PICTURE X(38).
002920     02  FILLER      PICTURE X(2)    VALUE ' *'.
002930     02  FILLER          PICTURE X(18)   VALUE SPACE.
002940 01  LINE-3.
002950     02  FILLER      PICTURE X   VALUE SPACE.
002960     02  FILLER      PICTURE X(113) VALUE ALL '*'.
002970     02  FILLER          PICTURE X(18)   VALUE SPACE.
002980 01  FOOTER.
002990     02  FILLER      PICTURE X(20)   VALUE SPACE.
003000     02  FILLER          PICTURE X(11)  VALUE  'SPACECRAFT '.
003010     02  SC-O            PICTURE X(7).
003020     02  FILLER          PICTURE X(13)   VALUE SPACE.
003030     02  FILLER      PICTURE X(12)   VALUE 'BOX NUMBER  '.
003040     02  BOX-F       PICTURE X(15).
003050     02  FILLER      PICTURE X(10)   VALUE '    DATE  '.
003060     02  DATE-F      PICTURE X(8)    VALUE SPACE.
003070     02  FILLER      PICTURE X(10)   VALUE '    PAGE  '.
003080     02  PAGE-F      PICTURE 9(3).
003090     02  FILLER      PICTURE X(4)    VALUE SPACE.
003100     02  FILLER          PICTURE X(19)   VALUE SPACE.
003110 01  BLANK-LINE.
003120     02  FILLER        PICTURE X(132)    VALUE SPACE.
003130 PROCEDURE DIVISION.
003140     OPEN INPUT UPDTAPE.
003150     OPEN INPUT OPT-CARD.
003160     OPEN  OUTPUT RPRTAPE.
003170     OPEN  OUTPUT MASTAPE.
003180     OPEN OUTPUT INDEX-LIST.
003190 READ-OPTION-CARD.
003200     WRITE RPT FROM BLANK-LINE AFTER POSITIONING 0.
003210     READ OPT-CARD AT END DISPLAY 'NO OPTION CARD'
003220                                 GO TO  END-OF-JOB.
003230                             NOTE -------------------------------
003240                             OPTION CARD CONTAINS 'YES (1-3) IF
003250                             THE BID REPORT IS DESIRED
003260                              AND/OR
003270                             'YES' (4-6) IF THE 149-CHARACTER TAPE
003280                             IS DESIRED
003290                             IF (1-3) IS 'YES' THE FOLLOWING
003300                             MUST APPEAR
003310                              (1) THE DATE TO APPEAR
003320                                  ON THE REPORT (25-32)
003330                              (2) THE CSM VEHICLE INVOLVED (41-47)
003340                              (3) THE LM  VEHICLE INVOLVED (51-57)
003350                             IF (4-6) IS 'YES' COLUMNS 7-24 IN
003360                             GROUPS OF 2 EACH ARE USED TO SELECT,
003370                             BY CONTRACTOR/AREA CODE, THE BID DATA
003380                             TO BE USED TO CREATE THE
003390                             149-CHARACTER TAPE
003400                             IF ALL DATA IS TO BE USED, 'ALL' CAN
003410                             BE CODED IN COLUMNS 7-9 WITH COLUMN
003420                             10 BLANK
003430                             -----------------------------------.
003440     MOVE DATE-ON-REPT TO DATE-F.
003450     MOVE 88 TO CNTR.
003460 READ-UPDATED-TAPE.
003470     READ  UPDTAPE INTO UPDT-HOLD AT END GO TO END-OF-JOB.
003480     ADD  1   TO   NO-IN-REC.
003490     IF CRDTP = 'B1'
003500         MOVE UPDT-HOLD TO B1-SAVE  PERFORM
003510         IS-IT-TAPE149-DATA THRU IITD-END.
003520     IF REPORT-OPTION = 'YES'
003530          PERFORM REPORTIT THRU REPRT-END.
003540     IF CA-SAV = 'NG' AND CRDTP = 'B1'
003550                  MOVE SPACE TO DRWGNO
003560                  MOVE GSE-DRAWING TO DRWGNO.
003570                             NOTE -------------------------------
003580                             IF THE CONTRACTOR/AREA CODE IS 'NG'
003590                             THE DATA IS GSE DATA WHICH MUST HAVE
003600                             A 3-CHARACTER BAY NUMBER FOR
003610                             UNIQUENESS, THIS BAY NUMBER IS FOUND
003620                             IN THE FIRST THREE COLUMNS OF THE
003630                             GSE-DRAWING NUMBER
003640                             -----------------------------------.
003650     IF TAPE149-OPTION = 'YES' AND TAPE-SWITCH = 'YES'
003660                          GO TO CREATE-TAPE-149
003670         ELSE    GO TO READ-UPDATED-TAPE.
003680 IS-IT-T149-DATA-NOTES.
003690                             NOTE -------------------------------
003700                             THIS PARAGRAPH SELECTS THE DATA BY
003710                             CONTRACTOR/AREA CODE AS INPUT ON THE
003720                             OPTION CARD
003730                             -----------------------------------.
003740 IS-IT-TAPE149-DATA.
003750     IF DUM1 = 'AL' AND DUM2 = 'L'
003760                 MOVE 'YES' TO TAPE-SWITCH
003770                 GO TO IITD-END.
003780     IF CA = DUM1 OR CA = DUM2 OR CA = DUM3 OR  CA = DUM4 OR
003790        CA = DUM5 OR CA = DUM6 OR CA = DUM7 OR  CA = DUM8 OR
003800        CA = DUM9
003810     MOVE 'YES' TO TAPE-SWITCH
003820         ELSE
003830                 MOVE ' NO' TO TAPE-SWITCH.
003840 IITD-END.
003850     EXIT.
003860 CREATE-TAPE-149-NOTES.
003870                             NOTE -------------------------------
003880                             THIS PARAGRAPH CREATES THE
003890                             149-CHARACTER TAPE
003900                             -----------------------------------.
003910 CREATE-TAPE-149.
003920     IF CRDTP = 'B1'
003930         MOVE BOXRF   TO  BOXRF-M
003940         MOVE CNTRCD  TO  FCONT-M TCONT-M
003950         MOVE CNTRCD  TO T-C-M-SAV  F-C-M-SAV
003960         MOVE AREACD  TO  FAREA-M TAREA-M
003970         MOVE AREACD  TO T-A-M-SAV  F-A-M-SAV
003980         MOVE DRWGNO  TO  DRWNO-M
003990         MOVE PARTNO  TO  PRTNO-M
004000         MOVE BOXTTL  TO  BXTTL-M
004010         GO TO READ-UPDATED-TAPE.
004020     IF BOXRF = BOXRF-M NEXT SENTENCE
004030         ELSE DISPLAY 'INCORRECT BOXREF ' UPDT-HOLD
004040         GO TO READ-UPDATED-TAPE.
004050     IF CA-SAV = 'NG' MOVE  GSE-BAY TO BAY-F BAY-T
004060         ELSE
004070             MOVE SPACE TO BAY-F BAY-T.
004080     MOVE F-ITEM TO FITEM-M
004090     MOVE F-PIN  TO F-PIN-M
004100     MOVE T-ITEM TO TITEM-M
004110     MOVE T-PIN  TO T-PIN-M
004120     MOVE DIODE  TO DIODE-M
004130     MOVE IMPED  TO IMPED-M
004140     MOVE RMRKS  TO RMRKS-M.
004150     IF TYP1  = 'PWR' MOVE 'PWR' TO TYP-REC
004160                      MOVE T-CA-M TO T-CA-M-SAV
004170                      MOVE F-CA-M TO F-CA-M-SAV
004180                      MOVE BLD-REC TO FCONN-M
004190                      GO TO CREATE-BID-MASTER.
004200     IF TYP1  = 'GND' MOVE 'GND' TO TYP-REC2
004210                      MOVE T-CA-M TO T-CA-M-SAV
004220                      MOVE F-CA-M TO F-CA-M-SAV
004230                      MOVE BLD-REC2 TO FCONN-M
004240                      GO TO CREATE-BID-MASTER.
004250     IF TYP2  = 'PWR' MOVE 'PWR' TO TYP-REC
004260                      MOVE T-CA-M TO T-CA-M-SAV
004270                      MOVE F-CA-M TO F-CA-M-SAV
004280                      MOVE BLD-REC TO TCONN-M
004290                      GO TO CREATE-BID-MASTER.
004300     IF TYP2  = 'GND' MOVE 'GND' TO TYP-REC2
004310                      MOVE T-CA-M TO T-CA-M-SAV
004320                      MOVE F-CA-M TO F-CA-M-SAV
004330                      MOVE BLD-REC2 TO TCONN-M
004340                      GO TO CREATE-BID-MASTER.
004350 CREATE-BID-MASTER.
004360     ADD  1   TO   NO-OU-REC.
004370     WRITE ASP-TAPE FROM MAST-REC.
004380     MOVE T-CA-M-SAV TO T-CA-M
004390     MOVE F-CA-M-SAV TO F-CA-M
004400     GO TO READ-UPDATED-TAPE.
004410 REPORTIT.
004420     IF CRDTP = 'B1'
004430             PERFORM WRITE-INDEX-LIST
004440             PERFORM PAGE-BOTTOM
004450             MOVE 1 TO PAGE-F
004460             MOVE BOXRF  TO  BOX-H1  BOX-F
004470             MOVE CNTRCD TO  CNTR-H1
004480             MOVE AREACD TO  AREA-H1
004490             MOVE DRWGNO TO  DRWN-H1
004500             MOVE PARTNO TO  PART-H1
004510             MOVE BOXTTL TO  BOXT-H1
004520             WRITE RPT FROM  LINE-3  AFTER POSITIONING 1
004530             WRITE RPT FROM  HEAD-11 AFTER POSITIONING 1
004540             WRITE RPT FROM  HEAD-12 AFTER POSITIONING 1
004550             WRITE RPT FROM  HEAD-13 AFTER POSITIONING 1
004560             WRITE RPT FROM  HEAD-14 AFTER POSITIONING 1
004570             WRITE RPT FROM  LINE-3  AFTER POSITIONING 1
004580             WRITE RPT FROM  HEAD-15 AFTER POSITIONING 1
004590             WRITE RPT FROM  LINE-1  AFTER POSITIONING 1
004600             WRITE RPT FROM  HEAD-15 AFTER POSITIONING 1
004610             WRITE RPT FROM  LINE-3  AFTER POSITIONING 1
004620             WRITE RPT FROM  HEAD-21 AFTER POSITIONING 1
004630             WRITE RPT FROM  HEAD-22 AFTER POSITIONING 1
004640             WRITE RPT FROM  HEAD-23 AFTER POSITIONING 1
004650             WRITE RPT FROM  HEAD-24 AFTER POSITIONING 1
004660             WRITE RPT FROM  LINE-3  AFTER POSITIONING 1
004670             MOVE 16 TO LNE-CNT
004680             GO TO REPRT-END-1.
004690     MOVE BOXRF  TO  BOX-H2
004700     MOVE F-ITEM TO  FITM-H2
004710     MOVE F-PIN  TO  FPIN-H2
004720     MOVE T-ITEM TO  TITM-H2
004730     MOVE T-PIN  TO  TPIN-H2
004740     MOVE DIODE  TO  DIOD-H2
004750     MOVE IMPED  TO  IMPD-H2
004760     MOVE RMRKS  TO  RMRK-H2.
004770     IF LNE-CNT < 60 PERFORM B2-WRITE
004780                     GO TO REPRT-END.
004790     PERFORM PAGE-BOTTOM.
004800 WRITE-HEADER3.
004810     WRITE RPT FROM LINE-3   AFTER POSITIONING 1.
004820     WRITE RPT FROM HEAD-21  AFTER POSITIONING 1.
004830     WRITE RPT FROM HEAD-22  AFTER POSITIONING 1.
004840     WRITE RPT FROM HEAD-23  AFTER POSITIONING 1.
004850     WRITE RPT FROM HEAD-24  AFTER POSITIONING 1.
004860     WRITE RPT FROM LINE-3   AFTER POSITIONING 1.
004870     MOVE 7 TO LNE-CNT ADD 1 TO PAGE-F.
004880 B2-WRITE.
004890     WRITE RPT FROM HEAD-25  AFTER POSITIONING 1.
004900     WRITE RPT FROM LINE-2   AFTER POSITIONING 1.
004910     ADD 2 TO LNE-CNT.
004920 RET.
004930     GO TO REPRT-END.
004940 PAGE-BOTTOM.
004950     WRITE RPT FROM LINE-3 AFTER POSITIONING 1.
004960     WRITE RPT FROM FOOTER AFTER POSITIONING 2.
004970     WRITE RPT FROM BLANK-LINE AFTER POSITIONING 0.
004980 REPRT-END-1.
004990     IF CNTRCD = 'N' MOVE CSM-I TO SC-O
005000         ELSE
005010     MOVE LM-I TO SC-O.
005020 REPRT-END.
005030     EXIT.
005040 WRITE-INDEX-LIST.
005050     ADD 1 TO CNTR.
005060     MOVE BOXRF TO BOX-H4.
005070     IF CNTR < 50 NEXT SENTENCE
005080        ELSE
005090             WRITE INDEXR FROM BLANK-LINE AFTER POSITIONING 0
005100             WRITE INDEXR FROM HDR        AFTER POSITIONING 1
005110             WRITE INDEXR FROM BLANK-LINE AFTER POSITIONING 1
005120             MOVE 3 TO CNTR.
005130         WRITE INDEXR FROM LINER-4 AFTER POSITIONING 1.
005140 END-OF-JOB.
005150         PERFORM PAGE-BOTTOM.
005160         DISPLAY  '  RECORDS  IN  NO-IN-REC  = ' NO-IN-REC.
005170         DISPLAY  '  RECORDS  OUT NO-OU-REC  = ' NO-OU-REC.
005180         CLOSE   UPDTAPE.
005190         CLOSE   OPT-CARD.
005200         CLOSE   RPRTAPE.
005210         CLOSE   MASTAPE.
005220         CLOSE INDEX-LIST.
005230     DISPLAY 'END OF RUN'.
005240         STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.    NAPP.
000030 AUTHOR.  JOE GROOVER.
000040 REMARKS.       NORTH AMERICAN PREPROCESSOR (AUTOMATIC MODE)
000050                FOR AREA MASTER TAPE.
000060 ENVIRONMENT DIVISION.
000070 CONFIGURATION SECTION.
000080 SOURCE-COMPUTER. IBM-360.
000090 OBJECT-COMPUTER. IBM-360.
000100 INPUT-OUTPUT SECTION.
000110 FILE-CONTROL.
000120     SELECT DUP-FILE     ASSIGN TO UT-S-DUPFILE.
000130     SELECT TRANS-IN     ASSIGN TO UT-S-TRANSIN.
000140     SELECT TRANS-SPLIT  ASSIGN TO UT-S-TRASPLIT.
000150     SELECT TRANS-SEARCH ASSIGN TO UT-S-TASEARCH.
000160     SELECT TRANS-OUT    ASSIGN TO UT-S-TRANSOUT.
000170 DATA DIVISION.
000180 FILE SECTION.
000190 FD  TRANS-IN
000200     RECORDING MODE IS F
000210     BLOCK CONTAINS 010 RECORDS
000220     RECORD CONTAINS 252 CHARACTERS
000230     LABEL RECORDS ARE OMITTED
000240     DATA RECORD IS TRANS-REC.
000250 01  TRANS-REC.
000260   02  FILLER        PICTURE X(252).
000270 FD  TRANS-OUT
000280     RECORDING MODE IS F
000290     BLOCK CONTAINS 005 RECORDS
000300     RECORD CONTAINS 38 CHARACTERS
000310     LABEL RECORDS ARE OMITTED
000320     DATA RECORD IS TB-06-RCD.
000330 01  TB-06-RCD.
000340     02  ITEM-PIN.
000350         03  ITEM-06     PICTURE X(8).
000360         03  PIN-06      PICTURE X(4).
000370     02  PART-NUMBER.
000380         03  PART-NO-5   PICTURE X(5).
000390         03  FILLER      PICTURE X(14).
000400     02  AREA-HARNESS-06.
000410         03  AREA-06 PICTURE X(3).
000420         03  HARNESS PICTURE X(4).
000430 FD  TRANS-SEARCH
000440     RECORDING MODE IS F
000450     BLOCK CONTAINS 10 RECORDS
000460     RECORD CONTAINS 087 CHARACTERS
000470     LABEL RECORDS ARE STANDARD
000480     DATA RECORD IS TRANS-SEARCH1.
000490 01  TRANS-SEARCH1.
000500   02  FILLER        PICTURE X(087).
000510 FD  TRANS-SPLIT
000520     RECORDING MODE IS F
000530     BLOCK CONTAINS 05 RECORDS
000540     RECORD CONTAINS 87 CHARACTERS
000550     LABEL RECORDS ARE OMITTED
000560     DATA RECORD IS TB-03-RCD.
000570 01  TB-03-RCD.
000580     02  FILLER  PICTURE X(87).
000590 FD  DUP-FILE
000600     RECORDING MODE IS F
000610     BLOCK CONTAINS 001 RECORDS
000620     RECORD CONTAINS 80 CHARACTERS
000630     LABEL RECORDS ARE OMITTED
000640     DATA RECORD IS TB-CARDS GRD-PT-CARDS EOF-CARD.
000650 01  TB-CARDS.
000660     02  TB-PART         PICTURE X(19).
000670     02  FILLER          PICTURE XXX.
000680     02  TB-NETWORK-NO   PICTURE XX.
000690     02  TB-PIN  OCCURS 14 TIMES PICTURE X(4).
000700 01  GRD-PT-CARDS.
000710     02  TB-ITEM         PICTURE X(8).
000720     02  FILLER          PICTURE X(4).
000730     02  TB-PART-N       PICTURE X(19).
000740     02  FILLER          PICTURE X(49).
000750 01  EOF-CARD.
000760     02  EOF         PICTURE XXX.
000770     02  FILLER      PICTURE X(77).
000780 WORKING-STORAGE SECTION.
000790 77  WS-STARTS-HERE  PICTURE X(08) VALUE '88888888'.
000800 77  I               PICTURE S9(09) COMPUTATIONAL SYNC.
000810 77  J               PICTURE S9(09) COMPUTATIONAL SYNC.
000820 77  K               PICTURE S9(09) COMPUTATIONAL SYNC.
000830 77  MAST-REC        PICTURE S9(09) COMPUTATIONAL VALUE +0 SYNC.
000840 77  DN-LNTH         PICTURE S9(09) COMPUTATIONAL VALUE +4 SYNC.
000850 77  MAX06           PICTURE S999 COMPUTATIONAL VALUE +0 SYNC.
000860 77  MAXNET          PICTURE S999 COMPUTATIONAL VALUE +0 SYNC.
000870 77  MAXPN           PICTURE S999 COMPUTATIONAL VALUE +0 SYNC.
000880 77  MAX-PART-NET    PICTURE S9(6) COMPUTATIONAL SYNC.
000890 77  H-WS-TO         PICTURE X(16) VALUE SPACES.
000900 77  LAST-PART       PICTURE X(19).
000910 77  N03 PICTURE S9(6) COMPUTATIONAL VALUE +0 SYNC.
000920 77  N06 PICTURE S9(6) COMPUTATIONAL VALUE +0 SYNC.
000930 77  FLAG    PICTURE X VALUE '0'.
000940 77  ITEM-HOLD   PICTURE X(8).
000950 01  WS-AREA.
000960     02  FILLER      PICTURE XX.
000970     02  CHAR-3      PICTURE X.
000980 01  WS-NETWORK.
000990     02  CHAR-1      PICTURE X.
001000     02  CHAR-2      PICTURE X.
001010 01  ITEM-PART-TABLE.
001020     02  ITEM-V-PART OCCURS  50  TIMES.
001030         03  ITEM        PICTURE X(8).
001040         03  PART-NAME   PICTURE X(19).
001050 01  PART-NETWORK-TABLE.
001060     02  PART-V-NETWORK OCCURS 100 TIMES.
001070         03  PART    PICTURE X(19).
001080         03  NETWORK-TBL OCCURS 200 TIMES.
001090             04  NET-NO  PICTURE XX.
001100             04  PINS    PICTURE X(4).
001110 01  TB-06-TABLE.
001120     02  TB-06   OCCURS 2000 TIMES.
001130         03  TB-ITEM-NO  PICTURE X(8).
001140         03  TB-PART-NO  PICTURE X(19).
001150         03  AREA-HARN.
001160             04  TB-AREA     PICTURE XXX.
001170             04  TB-HARNESS  PICTURE X(4).
001180         03  NETWORK     PICTURE XX.
001190 01  TRANS-RECORDS.
001200 02  TRANS-REC1.
001210   03  FILLER            PICTURE X(07).
001220   03  CD-NO         PICTURE X(01).
001230   03  FROM-CONN.
001240     04  F-TYPE      PICTURE X(02).
001250     04  F-NUMBER    PICTURE X(04).
001260     04  F-PIN       PICTURE X(04).
001270       04  F-PINS REDEFINES F-PIN PICTURE X(03).
001280       04  F-PINR REDEFINES F-PIN PICTURE X(01) OCCURS 4 TIMES.
001290   03  FILLER        PICTURE X(24).
001300   03  TO-CONN.
001310     04  T-TYPE      PICTURE X(02).
001320     04  T-NUMBER    PICTURE X(04).
001330     04  T-PIN       PICTURE X(04).
001340       04  T-PINS REDEFINES T-PIN PICTURE X(03).
001350       04  T-PINR REDEFINES T-PIN PICTURE X(01) OCCURS 4 TIMES.
001360   03  FILLER        PICTURE X(20).
001370   03  AREA-CODE.
001380     04  AC-1        PICTURE X(02).
001390     04  AC-2        PICTURE X(01).
001400   03  HARNESS-CODE  PICTURE X(5).
001410   03  REMARKS-1     PICTURE X(25).
001420   03  FILLER        PICTURE X(147).
001430 02  TRANS-REC2 REDEFINES TRANS-REC1.
001440   03  FILLER        PICTURE X(72).
001450   03  REF-DES       PICTURE X(7).
001460   03  FILLER        PICTURE X(173).
001470 02  TRANS-REC3 REDEFINES TRANS-REC2.
001480   03  FILLER        PICTURE X(18).
001490   03  NOMEN         PICTURE X(39).
001500   03  FILLER        PICTURE X(23).
001510   03  PART-NO       PICTURE X(19).
001520   03  FILLER        PICTURE X(153).
001530 01  WS-HOLD.
001540   02  WS-FROM.
001550     03  WS-CONT1    PICTURE X(01).
001560     03  WS-AREA1    PICTURE X(01).
001570     03  WS-FROM1.
001580       04  WS-TYPE1.
001590         05  WF-1        PICTURE X(01).
001600         05  FILLER      PICTURE X(01).
001610         05  WS-NUMBER1  PICTURE X(08).
001620       04 R-WS-TYPE1 REDEFINES WS-TYPE1.
001630         05  TB-TYPE PICTURE XX.
001640         05  FILLER  PICTURE X(8).
001650       04  WS-PIN1       PICTURE X(04).
001660   02  FROM-ITEM REDEFINES WS-FROM.
001670     03  ITEM-FROM   PICTURE X(8).
001680     03  FILLER      PICTURE X(8).
001690   02  WS-TO.
001700     03  WS-CONT2    PICTURE X(01).
001710     03  WS-AREA2    PICTURE X(01).
001720     03  WS-TO2.
001730       04  WS-TYPE2.
001740         05  WT-1        PICTURE X(01).
001750         05  FILLER      PICTURE X(01).
001760         05  WS-NUMBER2  PICTURE X(08).
001770       04 R-WS-TYPE2 REDEFINES WS-TYPE2.
001780         05  TB-TYP  PICTURE XX.
001790         05  FILLER  PICTURE X(8).
001800       04  WS-PIN2       PICTURE X(04).
001810   02  TO-ITEM REDEFINES WS-TO.
001820     03  ITEM-TO     PICTURE X(8).
001830     03  FILLER      PICTURE X(8).
001840   02  WS-REF-DES    PICTURE X(15).
001850   02 AREA-HARNESS-CODE REDEFINES WS-REF-DES.
001860     03  AREA-CD     PICTURE X(3).
001870     03  HARN-CD     PICTURE X(4).
001880     03  FILLER      PICTURE X(8).
001890   02  WS-REMARKS.
001900   03  FILLER        PICTURE X(39).
001910     03  WS-FLIP     PICTURE X(01).
001920 01  WS-HOLD-ALL.
001930   02  CONN-HOLD     PICTURE X(10).
001940 01  ANYFIELD.
001950   02  AF1           PICTURE X(40).
001960   02  AF1-R REDEFINES AF1 PICTURE X(01) OCCURS 40 TIMES.
001970   02  AF2           PICTURE X(40).
001980   02  AF2-R REDEFINES AF2 PICTURE X(01) OCCURS 40 TIMES.
001990 01  F-CONNECTOR.
002000   02 F-ITEM         PICTURE X(06).
002010   02 F-PINN         PICTURE X(04).
002020 01  T-CONNECTOR.
002030   02 T-ITEM         PICTURE X(06).
002040   02 T-PINN         PICTURE X(04).
002050 01  EDIT-REC.
002060     02  WS-TYPEX        PICTURE X(10).
002070     02  WS-TYPEY  REDEFINES WS-TYPEX PICTURE X OCCURS 10 TIMES.
002080     02  WS-TYP-WK       PICTURE X(10).
002090  02 WS-TYP-WK1 REDEFINES WS-TYP-WK PICTURE X OCCURS 10 TIMES.
002100 01  PIN-WORK-AREA.
002110   02  PIN-HOLD.
002120     03  NWK     PICTURE XX.
002130     03  NWKN    PICTURE XX.
002140 PROCEDURE DIVISION.
002150     OPEN OUTPUT TRANS-SPLIT.
002160     OPEN OUTPUT TRANS-OUT.
002170     OPEN OUTPUT TRANS-SEARCH.
002180     OPEN INPUT TRANS-IN.
002190 READ-TRANS-IN.
002200     READ TRANS-IN INTO TRANS-REC1 AT END
002210         CLOSE TRANS-IN
002220     CLOSE TRANS-SPLIT
002230     CLOSE TRANS-OUT
002240     GO TO READ-INPUT-STREAM.
002250     IF  AC-1 = 'C0' OR
002260         AC-1 = 'S0' OR
002270         AC-1 = 'L0' OR
002280         AC-1 = 'E0' NEXT SENTENCE ELSE
002290         GO TO READ-TRANS-IN.
002300     IF  CD-NO = '1'
002310         GO TO READ-TRANS-IN.
002320     IF CD-NO = '6' NEXT SENTENCE
002330         ELSE GO TO RT-0.
002340     IF FROM-CONN = CONN-HOLD
002350         GO TO READ-TRANS-IN.
002360     IF F-TYPE = 'TB' NEXT SENTENCE ELSE
002370         GO TO READ-TRANS-IN.
002380     PERFORM LOAD-WS-HOLD THRU LOAD-EX.
002390     MOVE WS-FROM TO ITEM-PIN.
002400     MOVE PART-NO TO PART-NUMBER.
002410     MOVE AREA-CODE TO AREA-06.
002420     MOVE HARNESS-CODE TO HARNESS.
002430     WRITE TB-06-RCD.
002440     COMPUTE N06 = N06 + 1.
002450     MOVE FROM-CONN TO CONN-HOLD.
002460     GO TO READ-TRANS-IN.
002470 RT-0.
002480     IF CD-NO = '3' NEXT SENTENCE ELSE
002490         DISPLAY '*** WARNING - INVALID CARD TYPE ON AREA MASTER T
002500-        'APE =' TRANS-REC1
002510         GO TO READ-TRANS-IN.
002520     MOVE FROM-CONN TO F-CONNECTOR.
002530     MOVE TO-CONN TO T-CONNECTOR.
002540     IF  F-CONNECTOR = SPACES OR
002550         T-CONNECTOR = SPACES
002560         GO TO READ-TRANS-IN.
002570     IF  F-ITEM = SPACES OR
002580         T-ITEM = SPACES
002590         GO TO READ-TRANS-IN.
002600 RT-1.
002610     IF  F-PINN = SPACES NEXT SENTENCE
002620         ELSE GO TO RT-1A.
002630     IF  F-TYPE = '0E' GO TO RT-1A ELSE
002640         DISPLAY '*** NON-BLANK ITEM WITH BLANK PIN FOR RECORD = '
002650         TRANS-REC1
002660         GO TO READ-TRANS-IN.
002670 RT-1A.
002680     IF  T-PINN = SPACES NEXT SENTENCE
002690         ELSE GO TO RT-2.
002700     IF  T-TYPE = '0E' GO TO RT-2 ELSE
002710         DISPLAY '*** NON-BLANK ITEM WITH BLANK PIN FOR RECORD = '
002720         TRANS-REC1
002730         GO TO READ-TRANS-IN.
002740 RT-2.
002750     IF  F-PIN = '   *' OR
002760         T-PIN = '   *'
002770         GO TO READ-TRANS-IN.
002780     IF  F-PINR (4) = 'F' OR
002790         F-PINR (4) = 'E' NEXT SENTENCE
002800     ELSE GO TO RT-3.
002810     TRANSFORM F-PIN FROM SPACES TO ZEROS.
002820     IF  F-PINS LESS THAN '001' OR
002830         F-PINS GREATER THAN '999' NEXT SENTENCE
002840     ELSE GO TO READ-TRANS-IN.
002850 RT-3.
002860     IF  T-PINR (4) = 'F' OR
002870         T-PINR (4) = 'E' NEXT SENTENCE
002880     ELSE GO TO RT-4.
002890     TRANSFORM T-PIN FROM SPACES TO ZEROS.
002900     IF  T-PINS LESS THAN '001' OR
002910         T-PINS GREATER THAN '999' NEXT SENTENCE
002920     ELSE GO TO READ-TRANS-IN.
002930 RT-4.
002940     PERFORM LOAD-WS-HOLD THRU LOAD-EX.
002950     MOVE SPACES TO WS-TYP-WK.
002960     MOVE WS-TYPE1  TO  WS-TYPEX.
002970     MOVE 2 TO I.
002980     MOVE 1 TO J.
002990     IF WF-1 = '0'   PERFORM LJ-FROM.
003000     MOVE SPACES TO WS-TYP-WK.    MOVE 2 TO I.  MOVE 1 TO J.
003010     MOVE WS-TYPE2  TO  WS-TYPEX.
003020     IF WT-1 = '0'  PERFORM LJ-TO.
003030     MOVE SPACE TO WS-FLIP.
003040     IF (F-TYPE = 'TB') OR (T-TYPE = 'TB')
003050         WRITE TB-03-RCD FROM WS-HOLD
003060         COMPUTE N03 = N03 + 1
003070         ELSE
003080         PERFORM WRITE-REVERSE.
003090         GO TO READ-TRANS-IN.
003100 LOAD-WS-HOLD.
003110     IF  AC-1 = 'C0' MOVE 'C' TO WS-AREA1 WS-AREA2  GO TO LOAD-1.
003120     IF  AC-1 = 'S0' MOVE 'S' TO WS-AREA1 WS-AREA2  GO TO LOAD-1.
003130     IF  AC-1 = 'L0' MOVE 'L' TO WS-AREA1 WS-AREA2  GO TO LOAD-1.
003140     IF AC-1 = 'E0' MOVE 'E' TO WS-AREA1 WS-AREA2 GO TO LOAD-1.
003150 LOAD-1.
003160     MOVE 'N' TO WS-CONT1 WS-CONT2.
003170     MOVE F-TYPE TO WS-TYPE1.
003180     MOVE F-NUMBER TO WS-NUMBER1.
003190     MOVE F-PIN TO WS-PIN1.
003200     MOVE T-TYPE TO WS-TYPE2.
003210     MOVE T-NUMBER TO WS-NUMBER2.
003220     MOVE T-PIN  TO WS-PIN2.
003230     MOVE REMARKS-1 TO WS-REMARKS.
003240     TRANSFORM WS-REMARKS FROM '%' TO '('.
003250     TRANSFORM WS-REMARKS FROM '&' TO '+'
003260     TRANSFORM WS-REMARKS FROM '<' TO ')'.
003270     TRANSFORM WS-PIN1 FROM SPACES TO ZEROS.
003280     TRANSFORM WS-PIN2 FROM SPACES TO ZEROS.
003290     MOVE REF-DES TO WS-REF-DES.
003300     GO TO LOAD-EX.
003310 LOAD-EX.
003320     EXIT.
003330 LJ-FROM.
003340     MOVE  WS-TYPEY (I)  TO  WS-TYP-WK1 (J).
003350     ADD  1  TO I.    ADD 1  TO J.
003360     IF  J  <  10     GO TO LJ-FROM.
003370     MOVE WS-TYP-WK TO WS-TYPE1.
003380 LJ-TO.
003390     MOVE  WS-TYPEY (I)  TO  WS-TYP-WK1 (J).
003400     ADD  1  TO I.   ADD  1  TO J.
003410     IF  J  <  10    GO TO LJ-TO.
003420     MOVE  WS-TYP-WK  TO  WS-TYPE2.
003430 LJ.
003440     EXAMINE AF1 TALLYING LEADING ZEROS.
003450     MOVE SPACES TO AF2.
003460     MOVE TALLY TO I.
003470     MOVE 0 TO J.
003480 LJ-1.
003490     ADD 1 TO I.
003500     ADD 1 TO J.
003510     IF  I GREATER DN-LNTH
003520         GO TO LJ-EX.
003530     MOVE AF1-R (I) TO AF2-R (J).
003540     GO TO LJ-1.
003550 LJ-EX.
003560     EXIT.
003570 READ-INPUT-STREAM.
003580     DISPLAY 'NO. 06 TB RCDS FOUND = ' N06.
003590     DISPLAY 'NO. 03 TB RCDS FOUND = ' N03.
003600     OPEN INPUT DUP-FILE.
003610     MOVE 1 TO I.
003620 READ-DATA-CARDS.
003630     READ DUP-FILE AT END GO TO EOF-INPUT-STREAM.
003640 CARD-SW.
003650     GO TO BUILD-P-N-TBL.
003660 BUILD-P-N-TBL.
003670     IF EOF = 'EOF' ALTER CARD-SW TO PROCEED TO BUILD-NETWORK-TBL
003680         GO TO SET-SUBSCRIPTS.
003690     MOVE TB-ITEM TO ITEM (I).
003700     MOVE TB-PART-N  TO  PART-NAME (I).
003710     COMPUTE I = I + 1.
003720     IF I GREATER 50
003730         DISPLAY 'PART/ITEM TABLE FILLED, JOB ENDED',
003740         CLOSE DUP-FILE,
003750         STOP RUN.
003760     GO TO READ-DATA-CARDS.
003770 SET-SUBSCRIPTS.
003780     COMPUTE MAXPN = I - 1.
003790     MOVE 0 TO I, J.
003800     MOVE 1 TO K.
003810     GO TO READ-DATA-CARDS.
003820 BUILD-NETWORK-TBL.
003830     EXAMINE TB-NETWORK-NO REPLACING LEADING SPACE BY ZERO.
003840     IF TB-PART = LAST-PART GO TO SAME-PART.
003850     IF J GREATER MAXNET MOVE J TO MAXNET.
003860     COMPUTE I = I + 1.
003870     MOVE 1 TO J.
003880     IF I GREATER 100
003890         DISPLAY 'NETWORK TABLE FILLED, JOB ENDED'
003900         CLOSE DUP-FILE,
003910         GOBACK.
003920     MOVE TB-PART TO PART (I).
003930     MOVE TB-PART TO LAST-PART.
003940 SAME-PART.
003950     IF TB-PIN (K) = SPACES
003960         MOVE 1 TO K,
003970         GO TO READ-DATA-CARDS.
003980     MOVE TB-NETWORK-NO TO NET-NO  (I, J).
003990     MOVE TB-PIN (K) TO PINS (I, J).
004000     COMPUTE K = K + 1.
004010     IF K GREATER 14
004020         MOVE 1 TO K,
004030         GO TO READ-DATA-CARDS.
004040     COMPUTE J = J + 1.
004050     IF J GREATER 200
004060         DISPLAY 'NETWORK TABLE OVERFLOW',
004070         DISPLAY 'PART NUMBER= ' TB-PART,
004080         DISPLAY 'NETWORK NUMBER= ' TB-NETWORK-NO,
004090         CLOSE DUP-FILE,
004100         STOP RUN.
004110     GO TO SAME-PART.
004120 EOF-INPUT-STREAM.
004130     CLOSE DUP-FILE.
004140     MOVE I TO MAX-PART-NET.
004150     OPEN INPUT TRANS-OUT.
004160     MOVE 1 TO I.
004170 READ-06-RCD.
004180     READ TRANS-OUT AT END GO TO END-06-RCDS.
004190     IF PART-NO-5 = 'MD417' GO TO BUILD-06-TBL.
004200     MOVE 1 TO J.
004210 FIND-PART-N.
004220     IF ITEM-06 = ITEM (J)
004230         MOVE PART-NAME (J) TO PART-NUMBER,
004240         GO TO BUILD-06-TBL.
004250     COMPUTE J = J + 1.
004260     IF J GREATER MAXPN
004270         DISPLAY 'NO PART-NO FOR ' TB-06-RCD,
004280         GO TO READ-06-RCD.
004290     GO TO FIND-PART-N.
004300 BUILD-06-TBL.
004310     MOVE ITEM-06  TO TB-ITEM-NO (I).
004320     MOVE PART-NUMBER TO TB-PART-NO (I).
004330     MOVE AREA-06 TO TB-AREA (I).
004340     MOVE HARNESS TO TB-HARNESS (I).
004350     MOVE AREA-06 TO WS-AREA.
004360     MOVE CHAR-3 TO CHAR-2.
004370     MOVE 'N' TO CHAR-1.
004380     MOVE WS-NETWORK TO NETWORK (I).
004390     COMPUTE I = I + 1.
004400     IF I GREATER 2000
004410         DISPLAY '06 RECORD TABLE OVERFLOW',
004420         GO TO END-06-RCDS.
004430     GO TO READ-06-RCD.
004440 END-06-RCDS.
004450     CLOSE TRANS-OUT.
004460     COMPUTE MAX06 = I - 1.
004470         DISPLAY '06 RECORD TABLE SIZE = ' MAX06.
004480     OPEN INPUT TRANS-SPLIT.
004490 READ-03.
004500     READ TRANS-SPLIT INTO WS-HOLD AT END GO TO END-OF-PGM.
004510     IF TB-TYPE = 'TB' NEXT SENTENCE
004520         ELSE GO TO TEST-TO-ITEM.
004530     MOVE ITEM-FROM TO ITEM-HOLD.
004540     PERFORM FIND-PART-NO.
004550     IF FLAG = '1'
004560         MOVE '0' TO FLAG
004570         GO TO READ-03.
004580     MOVE WS-PIN1 TO PIN-HOLD.
004590     PERFORM NETWORK-ASSIGN.
004600     IF FLAG = '1'
004610         MOVE '0' TO FLAG
004620         GO TO READ-03.
004630     MOVE PIN-HOLD TO WS-PIN1.
004640 TEST-TO-ITEM.
004650     IF TB-TYP = 'TB' NEXT SENTENCE
004660         ELSE GO TO WRITE-REVERSE.
004670     MOVE ITEM-TO TO ITEM-HOLD.
004680     PERFORM FIND-PART-NO.
004690     IF FLAG = '1'
004700         MOVE '0' TO FLAG
004710         GO TO READ-03.
004720     MOVE WS-PIN2 TO PIN-HOLD.
004730     PERFORM NETWORK-ASSIGN.
004740     IF FLAG = '1'
004750         MOVE '0' TO FLAG
004760         GO TO READ-03.
004770     MOVE PIN-HOLD TO WS-PIN2.
004780 WRITE-REVERSE.
004790     WRITE TRANS-SEARCH1 FROM WS-HOLD.
004800     COMPUTE MAST-REC = MAST-REC + 1.
004810     MOVE WS-TO TO H-WS-TO.
004820     MOVE WS-FROM TO WS-TO.
004830     MOVE H-WS-TO TO WS-FROM.
004840     MOVE '*' TO WS-FLIP.
004850     WRITE TRANS-SEARCH1 FROM WS-HOLD.
004860 END-WR.
004870     GO TO READ-03.
004880 END-OF-PGM.
004890     CLOSE TRANS-SEARCH.
004900     DISPLAY 'RECORDS OUT = ' MAST-REC.
004910     DISPLAY '*** NORMAL PROGRAM STOP REACHED ***'.
004920     STOP RUN.
004930 FIND-PART-NO SECTION.
004940     MOVE 1 TO I.
004950 TEST.
004960     IF (AREA-HARNESS-CODE = AREA-HARN (I))
004970         AND
004980        (ITEM-HOLD = TB-ITEM-NO (I))
004990         GO TO FIND-PART.
005000     COMPUTE I = I + 1.
005010     IF I GREATER MAX06
005020         DISPLAY 'NO MATCHING 06 RECORD ' TB-03-RCD
005030         MOVE '1' TO FLAG
005040         GO TO RTN1.
005050     GO TO TEST.
005060 FIND-PART.
005070     MOVE 1 TO J.
005080 TEST-PART-NO.
005090     IF TB-PART-NO (I) = PART (J)
005100         GO TO RTN1.
005110     COMPUTE J = J + 1.
005120     IF J GREATER MAX-PART-NET
005130         DISPLAY 'PART NO. NOT FOUND ' TB-03-RCD
005140         MOVE '1' TO FLAG
005150         GO TO RTN1.
005160     GO TO TEST-PART-NO.
005170 RTN1.
005180     EXIT.
005190 NETWORK-ASSIGN SECTION.
005200     MOVE 1 TO K.
005210 TEST-PIN.
005220     IF PIN-HOLD = PINS (J, K)
005230         MOVE NET-NO (J, K) TO NWKN
005240         MOVE NETWORK (I) TO NWK
005250         GO TO RTN2.
005260     COMPUTE K = K + 1.
005270     IF K GREATER MAXNET
005280         DISPLAY 'PIN NOT FOUND ' TB-03-RCD
005290         MOVE '1' TO FLAG
005300         GO TO RTN2.
005310     GO TO TEST-PIN.
005320 RTN2.
005330     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.   'GSEPREP'.
000030 AUTHOR.        LARRY J ROGOVEIN.
000040 INSTALLATION.  BOEING HOUSTON.
000050 DATE-WRITTEN.  JANUARY 22, 1969.
000060 DATE-COMPILED. MAY 15,1969.
000070 REMARKS.       THIS IS THE NORTH AMERICAN ROCKWELL GROUND SUPPORT
000080                EQUIPMENT PREPROCESSOR PROGRAM. IT PROCESSES THE
000090                DATA ON THE COPPER PATH INPUT MASTER BY;
000100                1) CHECKING FOR INVALID OR UNDESIREABLE SEGMENTS,
000110                2) REDUCING THE DATA TO A FORM ACCEPTABLE BY ASP,
000120                3) PRODUCING A DELECTION REPORT FOR DELETED
000130                   SEGMENTS.
000140 ENVIRONMENT DIVISION.
000150 CONFIGURATION SECTION.
000160 SOURCE-COMPUTER. IBM-360.
000170 OBJECT-COMPUTER. IBM-360.
000180 INPUT-OUTPUT SECTION.
000190 FILE-CONTROL.
000200     SELECT CARD   ASSIGN TO UT-S-CARDRD.
000210     SELECT CPIM   ASSIGN TO UT-S-CPIMSTR.
000220     SELECT CPOM   ASSIGN TO UT-S-CPOMSTR.
000230     SELECT DELREC    ASSIGN TO UT-S-DELRPT.
000240     SELECT SORTF   ASSIGN TO UT-S-SD1.
000250 DATA DIVISION.
000260 FILE SECTION.
000270 FD  CARD
000280     LABEL RECORD IS OMITTED
000290     RECORDING MODE IS F
000300     RECORD CONTAINS 80 CHARACTERS
000310     DATA RECORD IS HEADING-DATA.
000320 01  HEADING-DATA.
000330   02  TITLE   PICTURE X(47).
000340   02  VEHICLE PICTURE X(25).
000350   02  DATE    PICTURE X(8).
000360 FD  CPIM
000370     LABEL RECORD IS OMITTED
000380     RECORDING MODE IS F
000390     BLOCK CONTAINS 12 RECORDS
000400     RECORD CONTAINS 138 CHARACTERS
000410     DATA RECORD IS COPIN.
000420 01  COPIN.
000430   02  SIG-ID    PICTURE X(10).
000440   02  FILLER    PICTURE X.
000450   02  SIG-NOMCL PICTURE X(32).
000460   02  FILLER    PICTURE X.
000470   02  F-RD      PICTURE X(11).
000480   02  F-BAY     PICTURE XXX.
000490   02  F-TYPE    PICTURE XX.
000500   02  F-NUM     PICTURE XXXX.
000510   02  F-PIN     PICTURE XXXX.
000520   02  T-RD      PICTURE X(11).
000530   02  T-BAY     PICTURE XXX.
000540   02  T-TYPE    PICTURE XX.
000550   02  T-NUM     PICTURE XXXX.
000560   02  T-PIN     PICTURE XXXX.
000570   02  FILLER    PICTURE X(43).
000580   02  SPARE-INC PICTURE X.
000590   02  FILLER    PICTURE XX.
000600 FD  CPOM
000610     LABEL RECORD IS STANDARD
000620     RECORDING MODE IS F
000630     BLOCK CONTAINS 20 RECORDS
000640     RECORD CONTAINS 87 CHARACTERS
000650     DATA RECORD IS COPOUT.
000660 01  COPOUT.
000670   02  COPOUT-FROM  PICTURE X(16).
000680   02  COPOUT-TO    PICTURE X(16).
000690   02  AREA-HARNESS PICTURE X(15).
000700   02  REMARK        PICTURE X(38).
000710   02  BED-FLAG      PICTURE X.
000720   02  FLIP-FLOP    PICTURE X.
000730 FD  DELREC
000740     LABEL RECORD IS OMITTED
000750     RECORDING MODE IS F
000760     RECORD CONTAINS 132 CHARACTERS
000770     DATA RECORD IS DR.
000780 01  DR.
000790   02  DR-1TO9           PICTURE X(9).
000800   02  DR-10TO56.
000810     03  DR-10TO19.
000820       04  DR-10TO11     PICTURE XX.
000830       04  DR-12TO17     PICTURE X(6).
000840       04  DR-18TO19     PICTURE XX.
000850     03  DR-20TO25       PICTURE X(6).
000860     03  DR-26TO56.
000870       04  DR-26TO31     PICTURE X(6).
000880       04  DR-32TO50     PICTURE X(19).
000890       04  DR-51TO56     PICTURE X(6).
000900   02  DR-57TO61         PICTURE X(5).
000910   02  DR-62TO86.
000920     03  DR-62TO72.
000930       04  DR-62TO63     PICTURE XX.
000940       04  DR-64TO70     PICTURE X(7).
000950       04  DR-71TO72     PICTURE XX.
000960     03  DR-73           PICTURE X.
000970     03  DR-74TO77.
000980       04  DR-74         PICTURE X.
000990       04  DR-75TO76     PICTURE XX.
001000       04  DR-77         PICTURE X.
001010     03  DR-78           PICTURE X.
001020     03  DR-79TO82.
001030       04  DR-79         PICTURE X.
001040       04  DR-80TO81     PICTURE XX.
001050       04  DR-82         PICTURE X.
001060     03  DR-83           PICTURE X.
001070     03  DR-84TO86       PICTURE XXX.
001080   02  DR-87TO96.
001090     03  DR-87           PICTURE X.
001100     03  DR-88TO91.
001110       04  DR-88         PICTURE X.
001120       04  DR-89TO91     PICTURE XXX.
001130     03  DR-92TO96       PICTURE X(5).
001140   02  DR-97TO107.
001150     03  DR-97TO104.
001160       04  DR-97TO103    PICTURE X(7).
001170       04  DR-104        PICTURE X.
001180     03  DR-105TO107     PICTURE XXX.
001190   02  DR-108            PICTURE X.
001200   02  DR-109TO112.
001210     03  DR-109          PICTURE X.
001220     03  DR-110TO111     PICTURE XX.
001230     03  DR-112          PICTURE X.
001240   02  DR-113            PICTURE X.
001250   02  DR-114TO117.
001260     03  DR-114          PICTURE X.
001270     03  DR-115TO116     PICTURE XX.
001280     03  DR-117          PICTURE X.
001290   02  DR-118            PICTURE X.
001300   02  DR-119TO121       PICTURE XXX.
001310   02  DR-122            PICTURE X.
001320   02  DR-123TO126.
001330     03  DR-123          PICTURE X.
001340     03  DR-124TO126     PICTURE XXX.
001350   02  DR-127TO132       PICTURE X(6).
001360 SD  SORTF
001370     RECORDING MODE IS F
001380     RECORD CONTAINS 87 CHARACTERS
001390     DATA RECORD IS SS.
001400 01  SS.
001410   02  SS-1TO15.
001420     03  SS-1TO11    PICTURE X(11).
001430     03  SS-12TO15   PICTURE X(4).
001440   02  SS-16TO47.
001450     03  SS-16TO31.
001460       04  SS-16     PICTURE X.
001470       04  SS-17     PICTURE X.
001480       04  SS-18     PICTURE X.
001490       04  SS-19TO22 PICTURE XXXX.
001500       04  SS-23     PICTURE X.
001510       04  SS-24TO26 PICTURE XXX.
001520       04  SS-27     PICTURE X.
001530       04  SS-28TO31 PICTURE XXXX.
001540     03  SS-32TO47.
001550       04  SS-32     PICTURE X.
001560       04  SS-33     PICTURE X.
001570       04  SS-34     PICTURE X.
001580       04  SS-35TO38 PICTURE XXXX.
001590       04  SS-39     PICTURE X.
001600       04  SS-40TO42 PICTURE XXX.
001610       04  SS-43     PICTURE X.
001620       04  SS-44TO47 PICTURE XXXX.
001630   02  SS-48TO85.
001640     03  SS-48TO74   PICTURE X(27).
001650     03  SS-75TO85   PICTURE X(11).
001660   02  SS-86         PICTURE X.
001670   02  SS-87 PICTURE X.
001680 WORKING-STORAGE SECTION.
001690 77  COUNT-ASTRICK-J     PICTURE 9(6)    VALUE 0.
001700 77  COUNT-COPOUT-REC    PICTURE 9(6)    VALUE 0.
001710 77  COUNT-DELETIONS     PICTURE 9(6)    VALUE 0.
001720 77  COUNT-SPARES        PICTURE 9(6)    VALUE 0.
001730 77  DELETION-FLAG   PICTURE 9.
001740 77  FLAG-OFF    PICTURE 9   VALUE 0.
001750 77  FLAG-ON     PICTURE 9   VALUE 1.
001760 77  LAST-POS    PICTURE 9.
001770 77  LINE-COUNT  PICTURE 99.
001780 77  NO-LINES    PICTURE 99      VALUE 55.
001790 77  PAGE-NO     PICTURE 999 VALUE ZERO.
001800 77  POS         PICTURE 9.
001810 77  POSP1       PICTURE 9.
001820 77  QUO         PICTURE 9.
001830 77  REM         PICTURE 9.
001840 77  TYPE-FLAG       PICTURE 9.
001850 01  CCC.
001860   02  C OCCURS 4 TIMES.
001870     03 CC PICTURE X.
001880 01  WS.
001890   02  WS-1TO27.
001900     03  WS-1TO10.
001910       04  WS-1TO2.
001920         05  WS-1    PICTURE X.
001930         05  WS-2    PICTURE X.
001940       04  WS-3TO6.
001950         05  WS-3    PICTURE X.
001960         05  WS-4    PICTURE X.
001970         05  WS-5    PICTURE X.
001980         05  WS-6    PICTURE X.
001990         05  WS-6A REDEFINES WS-6 PICTURE 9.
002000       04  WS-7      PICTURE X.
002010       04  WS-8      PICTURE X.
002020       04  WS-9TO10  PICTURE XX.
002030     03  WS-11TO26.
002040       04  WS-11TO21 PICTURE X(11).
002050       04  WS-22TO26 PICTURE X(5).
002060     03  WS-27       PICTURE X.
002070   02  WS-28TO32     PICTURE X(5).
002080 PROCEDURE DIVISION.
002090 INITIAL SECTION.
002100     OPEN INPUT CPIM, CARD.
002110     OPEN OUTPUT CPOM, DELREC.
002120     READ CARD AT END GO TO CLOSE-FILES.
002130     PERFORM PAGE-HEADING.
002140     SORT SORTF ON ASCENDING KEY SS-16TO47
002150         INPUT PROCEDURE VALID-RECORD THRU DELETION-REPORT
002160         OUTPUT PROCEDURE WRITE-COPOUT.
002170         GO TO CLOSE-FILES.
002180 VALID-RECORD SECTION.
002190     MOVE SPACES TO SS-12TO15, SS-23, SS-27, SS-39, SS-43.
002200     MOVE '$' TO SS-86.
002210     MOVE 'N' TO SS-16, SS-32.
002220     MOVE 'G' TO SS-17, SS-33.
002230 SORT-INPUT-START.
002240     READ CPIM AT END GO TO S-I-EXIT.
002250     IF SPARE-INC NOT EQUAL ZERO, ADD 1 TO COUNT-SPARES,
002260                                  GO TO SORT-INPUT-START.
002270 BCD-TO-EBCDIC.
002280     TRANSFORM COPIN CHARACTERS FROM '<%#&@' TO ')(=+0'.
002290     TRANSFORM F-PIN CHARACTERS FROM SPACE TO ZERO.
002300     TRANSFORM T-PIN CHARACTERS FROM SPACE TO ZERO.
002310 VALID-RECORD-TEST.
002320     MOVE SIG-ID TO WS-1TO10.
002330     IF WS-2 EQUAL 'Y' GO TO DELETION-REPORT.
002340     IF WS-8 EQUAL 'S' GO TO DELETION-REPORT.
002350 DATA-REDUCTION SECTION.
002360 FROM-TEST.
002370     MOVE F-TYPE TO WS-1TO2.
002380     PERFORM VALID-TYPE.
002390     IF DELETION-FLAG EQUAL FLAG-ON GO TO DELETION-REPORT.
002400     IF TYPE-FLAG EQUAL FLAG-ON GO TO TO-TEST.
002410     MOVE WS-2 TO SS-18.
002420     MOVE SIG-NOMCL TO WS.
002430     MOVE WS-1TO27 TO SS-48TO74.
002440     MOVE F-RD TO SS-1TO11.
002450     MOVE F-NUM TO SS-19TO22.
002460     MOVE F-BAY TO SS-24TO26.
002470     MOVE SPACE TO SS-87.
002480     MOVE F-PIN TO WS-3TO6.
002490     PERFORM IMBEDDED-ZEROS THRU JUMPER-PIN.
002500     MOVE WS-3TO6 TO SS-28TO31.
002510 TO-TEST.
002520     MOVE T-TYPE TO WS-1TO2.
002530     PERFORM VALID-TYPE.
002540     IF DELETION-FLAG EQUAL FLAG-ON GO TO DELETION-REPORT.
002550     IF TYPE-FLAG EQUAL FLAG-ON, ADD 1 TO COUNT-ASTRICK-J,
002560                                 GO TO SORT-INPUT-START.
002570     MOVE WS-2 TO SS-34.
002580     MOVE T-RD TO SS-75TO85.
002590     MOVE T-NUM TO SS-35TO38.
002600     MOVE T-BAY TO SS-40TO42.
002610     MOVE T-PIN TO WS-3TO6.
002620     PERFORM IMBEDDED-ZEROS THRU JUMPER-PIN.
002630     MOVE WS-3TO6 TO SS-44TO47.
002640     RELEASE SS.
002650     MOVE SS-16TO31 TO WS-11TO26.
002660     MOVE SS-32TO47 TO SS-16TO31.
002670     MOVE WS-11TO26 TO SS-32TO47.
002680     MOVE SS-1TO11 TO WS-11TO21.
002690     MOVE SS-75TO85 TO SS-1TO11.
002700     MOVE WS-11TO21 TO SS-75TO85.
002710     MOVE '*' TO SS-87.
002720     RELEASE SS.
002730     GO TO SORT-INPUT-START.
002740 VALID-TYPE SECTION.
002750     MOVE FLAG-OFF TO DELETION-FLAG, TYPE-FLAG.
002760     IF WS-1TO2 EQUAL '*J' MOVE FLAG-ON TO TYPE-FLAG
002770         GO TO V-T-EXIT.
002780     IF WS-1TO2 EQUAL '0E' OR ' E', GO TO V-T-EXIT.
002790     IF WS-1TO2 EQUAL '0J' OR ' J', GO TO V-T-EXIT.
002800     IF WS-1TO2 EQUAL '0P' OR ' P', GO TO V-T-EXIT.
002810     MOVE FLAG-ON TO DELETION-FLAG.
002820 V-T-EXIT.
002830     EXIT.
002840 IMBEDDED-ZEROS SECTION.
002850     IF WS-3TO6 EQUAL SPACES GO TO I-Z-EXIT.
002860     MOVE WS-3 TO C (1).
002870     MOVE WS-4 TO C (2).
002880     MOVE WS-5 TO C (3).
002890     MOVE WS-6 TO C (4).
002900     MOVE ZERO TO POS.
002910 SEARCH-LOOP.
002920     ADD 1 TO POS.
002930     ADD 1, POS GIVING POSP1.
002940     IF C (POS) NOT EQUAL ZERO GO TO SHIFT-ZEROS.
002950     IF POS LESS THAN 3 GO TO SEARCH-LOOP ELSE GO TO RELOAD.
002960 SHIFT-ZEROS.
002970     MOVE POS TO LAST-POS.
002980     IF C (POS) NUMERIC GO TO PASS-3-TEST.
002990 SECOND-ZERO.
003000     IF C (POSP1) NOT EQUAL ZERO GO TO PASS-3-TEST.
003010 SHIFT-RIGHT.
003020     MOVE C (POS) TO C (POSP1).
003030     SUBTRACT 1 FROM POS.
003040     ADD 1, POS GIVING POSP1.
003050     IF POS GREATER THAN ZERO GO TO SHIFT-RIGHT.
003060     MOVE ZERO TO C (1).
003070     IF LAST-POS EQUAL 3 GO TO RELOAD.
003080     IF LAST-POS EQUAL 2 GO TO PASS-3.
003090 PASS-2.
003100     MOVE 2 TO LAST-POS, POS.
003110     GO TO SECOND-ZERO.
003120 PASS-3-TEST.
003130     IF LAST-POS EQUAL 3 GO TO RELOAD.
003140     IF C (POSP1) NUMERIC GO TO PASS-1-TEST.
003150     IF LAST-POS EQUAL 1 GO TO PASS-2.
003160 PASS-3.
003170     MOVE 3 TO LAST-POS, POS.
003180     GO TO SECOND-ZERO.
003190 PASS-1-TEST.
003200     IF LAST-POS EQUAL 1 GO TO PASS-2.
003210 RELOAD.
003220     MOVE C (1) TO WS-3.
003230     MOVE C (2) TO WS-4.
003240     MOVE C (3) TO WS-5.
003250     MOVE C (4) TO WS-6.
003260 I-Z-EXIT.
003270     EXIT.
003280 JUMPER-PIN SECTION.
003290     IF WS-3 NOT EQUAL ZERO GO TO J-P-EXIT.
003300     IF WS-4 NOT EQUAL ZERO GO TO J-P-EXIT.
003310     IF WS-5 NOT ALPHABETIC GO TO J-P-EXIT.
003320     IF WS-6 ALPHABETIC, GO TO J-P-EXIT.
003330     COMPUTE QUO = WS-6A / 2.
003340     COMPUTE REM = WS-6A - 2 * QUO.
003350     IF REM EQUAL ZERO GO TO J-P-EXIT.
003360     ADD 1 TO WS-6A.
003370 J-P-EXIT.
003380     EXIT.
003390 DELETION-REPORT SECTION.
003400     MOVE SPACES TO DR.
003410     MOVE SIG-ID TO DR-10TO19.
003420     MOVE SIG-NOMCL TO DR-32TO50.
003430     MOVE F-RD TO DR-64TO70.
003440     MOVE F-TYPE TO DR-75TO76.
003450     MOVE F-NUM TO DR-79TO82.
003460     MOVE F-BAY TO DR-84TO86.
003470     MOVE F-PIN TO DR-88TO91.
003480     MOVE T-RD TO DR-97TO107.
003490     MOVE T-TYPE TO DR-110TO111.
003500     MOVE T-NUM TO DR-114TO117.
003510     MOVE T-BAY TO DR-119TO121.
003520     MOVE T-PIN TO DR-123TO126.
003530     WRITE DR AFTER POSITIONING 1.
003540     ADD 1 TO COUNT-DELETIONS.
003550     ADD 1 TO LINE-COUNT.
003560     IF LINE-COUNT GREATER THAN NO-LINES PERFORM PAGE-HEADING.
003570     GO TO SORT-INPUT-START.
003580 PAGE-HEADING.
003590     MOVE ZERO TO LINE-COUNT.
003600     ADD 1 TO PAGE-NO.
003610     MOVE SPACES TO DR.
003620     MOVE TITLE  TO DR-10TO56.
003630     MOVE VEHICLE TO DR-62TO86.
003640     MOVE DATE TO DR-97TO104.
003650     MOVE 'PAGE' TO DR-114TO117.
003660     MOVE PAGE-NO TO DR-119TO121.
003670     WRITE DR AFTER POSITIONING 0.
003680     MOVE SPACES TO DR.
003690     MOVE 'SIGNAL  ID' TO DR-10TO19.
003700     MOVE 'SIGNAL NOMENCLATURE' TO DR-32TO50.
003710     MOVE 'FROM' TO DR-74TO77.
003720     MOVE 'TO' TO DR-110TO111.
003730     WRITE DR AFTER POSITIONING 2.
003740     MOVE SPACES TO DR.
003750     MOVE 'NUMBER' TO DR-12TO17.
003760     MOVE 'REF-DES' TO DR-64TO70, DR-97TO103.
003770     MOVE 'TYPE' TO DR-74TO77, DR-109TO112.
003780     MOVE 'NO' TO DR-80TO81, DR-115TO116.
003790     MOVE 'BAY' TO DR-84TO86, DR-119TO121.
003800     MOVE 'PIN' TO DR-89TO91, DR-124TO126.
003810     WRITE DR AFTER POSITIONING 1.
003820     MOVE SPACES TO DR.
003830     WRITE DR AFTER POSITIONING 1.
003840 S-I-EXIT.
003850     EXIT.
003860 WRITE-COPOUT SECTION.
003870 SORT-OUTPUT-START.
003880     RETURN SORTF AT END GO TO CLOSE-REPORT.
003890     MOVE SS-1TO15 TO AREA-HARNESS.
003900     MOVE SS-16TO31 TO COPOUT-FROM.
003910     MOVE SS-32TO47 TO COPOUT-TO.
003920     MOVE SS-48TO85 TO REMARK.
003930     MOVE SS-86 TO BED-FLAG.
003940     MOVE SS-87 TO FLIP-FLOP.
003950     WRITE COPOUT.
003960     ADD 1 TO COUNT-COPOUT-REC.
003970     GO TO SORT-OUTPUT-START.
003980 CLOSE-REPORT.
003990     IF PAGE-NO NOT EQUAL 1, GO TO FINAL-COMMENTS.
004000     IF LINE-COUNT EQUAL ZERO,
004010         MOVE SPACES TO DR,
004020         MOVE 'NO DELETIONS NEEDED' TO DR-32TO50,
004030         WRITE DR AFTER POSITIONING 3.
004040 FINAL-COMMENTS.
004050     MOVE SPACES TO DR.
004060     MOVE COUNT-SPARES TO DR-12TO17.
004070     MOVE 'SPARE ' TO DR-20TO25.
004080     MOVE 'RECORDS NOT PROCESSED OR REPORT' TO DR-26TO56.
004090     MOVE 'ED   ' TO DR-57TO61.
004100     WRITE DR AFTER POSITIONING 0.
004110     MOVE SPACES TO DR.
004120     MOVE COUNT-DELETIONS TO DR-12TO17.
004130     MOVE 'RECORD' TO DR-20TO25.
004140     MOVE 'S FOUND, DELETED, AND REPORTED ' TO DR-26TO56.
004150     WRITE DR AFTER POSITIONING 2.
004160     MOVE SPACES TO DR.
004170     MOVE COUNT-ASTRICK-J TO DR-12TO17.
004180     MOVE 'PAIRS ' TO DR-20TO25.
004190     MOVE 'OF *J RECORDS FOUND AND DELETED' TO DR-26TO56.
004200     WRITE DR AFTER POSITIONING 2.
004210     MOVE SPACES TO DR.
004220     MOVE COUNT-COPOUT-REC TO DR-12TO17.
004230     MOVE 'PRIMAR' TO DR-20TO25.
004240     MOVE 'Y RECORDS PROCESSED FOR CPOMSTR' TO DR-26TO56.
004250     WRITE DR AFTER POSITIONING 2.
004260     MOVE SPACES TO DR.
004270     MOVE 'PROCESSING COMPLETE' TO DR-32TO50.
004280     WRITE DR AFTER POSITIONING 2.
004290 S-O-EXIT.
004300     EXIT.
004310 CLOSE-FILES SECTION.
004320     CLOSE CARD, CPIM, CPOM, DELREC.
004330     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. GRUMN.
000030 AUTHOR. ALDEN GUILLORY.
000040 REMARKS.        GRUMMAN PREPROCESSOR FOR AREA MASTER    SNEAK
000050                 AUTOMATIC MODE                          CIRCUIT
000060         BOEING HOUSTON                                  ANALYSIS
000070         JANUARY 10, 1969.
000080 ENVIRONMENT DIVISION.
000090 CONFIGURATION SECTION.
000100 SOURCE-COMPUTER. IBM-360.
000110 OBJECT-COMPUTER. IBM-360.
000120 INPUT-OUTPUT SECTION.
000130 FILE-CONTROL.
000140     SELECT  OPT-FLE     ASSIGN TO UT-S-OPTFL.
000150     SELECT  GRUM-TP     ASSIGN TO UT-S-GRUMT.
000160     SELECT  AUX-STO     ASSIGN TO UT-S-AUXST.
000170     SELECT  SRT2WAY     ASSIGN TO UT-S-SORTOUT.
000180     SELECT  RPT-TP1     ASSIGN TO UT-S-RPTOUT.
000190     SELECT  WIRE-S2     ASSIGN TO UT-S-WIRES2.
000200     SELECT  WIRE-S1     ASSIGN TO UT-S-WIRES1.
000210
000220
000230
000240 DATA DIVISION.
000250 FILE SECTION.
000260 FD  OPT-FLE
000270     RECORDING MODE IS F
000280     RECORD CONTAINS 80 CHARACTERS
000290     LABEL RECORDS ARE OMITTED
000300     DATA RECORD IS OPT-CD.
000310 01  OPT-CD.
000320   02    FILLER              PICTURE X(80).
000330 FD  GRUM-TP
000340     RECORDING MODE IS F
000350     BLOCK CONTAINS  50  RECORDS
000360     RECORD CONTAINS 68  CHARACTERS
000370     LABEL RECORDS ARE OMITTED
000380     DATA RECORD IS GRUM-DA.
000390 01  GRUM-DA.
000400   02  FROM-C                PICTURE X(10).
000410   02  FR-GAUGE              PICTURE XX.
000420   02  TO-C                  PICTURE X(10).
000430   02  TO-GAUGE              PICTURE XX.
000440   02  DWG-NO                PICTURE X(12).
000450   02  NOMEN                 PICTURE X(18).
000460   02  WIRE-NO               PICTURE X(14).
000470 FD  AUX-STO
000480     RECORDING MODE IS F
000490     RECORD CONTAINS 64  CHARACTERS
000500     BLOCK CONTAINS  50  RECORDS
000510     LABEL RECORDS ARE OMITTED
000520     DATA RECORD IS TEMP.
000530 01  TEMP.
000540   02    AUX-WR              PICTURE X(14).
000550   02    AUX-DW              PICTURE X(12).
000560   02   AUX-FR               PICTURE X(10).
000570   02    AUX-TO              PICTURE X(10).
000580   02    AUX-NO              PICTURE X(18).
000590 FD  SRT2WAY
000600     RECORDING MODE IS F
000610     BLOCK CONTAINS  20 RECORDS
000620     RECORD CONTAINS  87 CHARACTERS
000630     LABEL RECORDS ARE OMITTED
000640     DATA RECORD IS  SOUT.
000650 01  SOUT.
000660   02  FR-CONN           PICTURE X(16).
000670   02  TO-CONN           PICTURE X(16).
000680   02  REF-DESS2-WIRE-NO     PICTURE X(14).
000690   02  FILLER                PICTURE X.
000700   02  ROMRKS.
000710     03  NOMENS2             PICTURE X(18).
000720     03  FILLER              PICTURE X(6).
000730   02  DRAWING-S2            PICTURE X(12).
000740   02  FILLER                PICTURE X(3).
000750   02  DUPS2                 PICTURE X.
000760 SD  WIRE-S2
000770     RECORDING  MODE IS  F
000780     DATA RECORD IS  SRT-F2.
000790 01  SRT-F2.
000800     02  FROM-CONT.
000810         03  CONTRACTOR-F    PICTURE X.
000820         03  AREA-CD-F       PICTURE X.
000830         03  PJ-FROM         PICTURE X.
000840         03  NUMBER-TYP-F    PICTURE X(4).
000850         03  ALPHA-FR        PICTURE X.
000860         03  FILLER          PICTURE X(4).
000870         03  PIN-NO-F        PICTURE X(4).
000880     02  TO-CONT.
000890         03  CONTRACTOR-T    PICTURE X.
000900         03  AREA-CD-T       PICTURE X.
000910         03  PJ-TO-S2        PICTURE X.
000920         03  NUMBER-TYP-T    PICTURE X(4).
000930         03  ALPHA-TO        PICTURE X.
000940         03  FILLER          PICTURE X(4).
000950         03  PIN-NO-T        PICTURE X(4).
000960     02  WIRE-NO-S2          PICTURE X(14).
000970     02  FILLER              PICTURE X.
000980     02  REMARKSS2.
000990         03  NOMEN-S2        PICTURE X(18).
001000         03  FILLER          PICTURE X(6).
001010         03  DROW-NO         PICTURE X(12).
001020         03  FILLER          PICTURE X(3).
001030         03  DUPLICATE-S2    PICTURE X.
001040 SD  WIRE-S1
001050     RECORDING MODE IS F
001060     DATA RECORD IS  SRT-F1.
001070 01  SRT-F1.
001080   02 FR-CONS1               PICTURE X(10).
001090   02 FR-GAUGS1              PICTURE XX.
001100   02 TO-CONS1               PICTURE X(10).
001110   02 TO-GAUGS1              PICTURE XX.
001120   02 DWG-NOS1               PICTURE X(12).
001130   02 NOMEN-S1               PICTURE X(18).
001140   02 WIRE-NOS1              PICTURE X(14).
001150 FD  RPT-TP1
001160     RECORDING MODE IS F
001170     BLOCK CONTAINS  10  RECORDS
001180     RECORD CONTAINS 132 CHARACTERS
001190     LABEL RECORDS ARE OMITTED
001200     DATA RECORD IS  MESSAGX.
001210 01  MESSAGX                 PICTURE X(132).
001220 WORKING-STORAGE SECTION.
001230 77  WS-STS-HR           PICTURE X(16) VALUE 'WS-STS-H88888888'.
001240 77  I                   PICTURE S9(4) COMPUTATIONAL VALUE ZERO.
001250 77  J                   PICTURE S9(4) COMPUTATIONAL VALUE ZERO.
001260 77  SWT1                PICTURE S9(4) COMPUTATIONAL VALUE ZERO.
001270 77  ILL-DAT             PICTURE 9   VALUE 0.
001280 77  K                   PICTURE 9(4) VALUE 0.
001290 77  LIN-CT              PICTURE 99  VALUE 45.
001300 77  PG-CT               PICTURE 999 VALUE 0.
001310 77  ALL-DONE                PICTURE 9   VALUE ZERO.
001320 01  OPT-HLD.
001330   02  OPT-1             PICTURE X(5).
001340   02  FILLER            PICTURE X(5).
001350   02  OPT-2             PICTURE X(3).
001360   02  FILLER            PICTURE X(5).
001370   02  DATE-1            PICTURE X(8).
001380   02  FILLER            PICTURE X(5).
001390   02  SP-CRT            PICTURE X(15).
001400   02  FILLER            PICTURE X(34).
001410 01  GRUM-HLD.
001420   02  FR-HLD            PICTURE X(12).
001430   02  TO-HLD            PICTURE X(12).
001440   02  DWG-HLD           PICTURE X(12).
001450   02  NOMEN-HLD         PICTURE X(18).
001460   02  WIRE-NO-HLD       PICTURE X(14).
001470 01  FR-TO.
001480  02 CONN-1              PICTURE X(10).
001490  02 CON-2       REDEFINES CONN-1    PICTURE X OCCURS 10 TIMES.
001500  02 CON-1 REDEFINES CONN-1.
001510     03  TF-TYP          PICTURE X(6).
001520     03  FILLER          PICTURE X(4).
001530  02 GAUGE.
001540     03  G-1             PICTURE X.
001550     03  G-2             PICTURE X.
001560 01  LINER.
001570  02 FILLER              PICTURE X(132)  VALUE SPACES.
001580 01  HEADER1.
001590  02 FILLER              PICTURE X(5)    VALUE SPACES.
001600  02 FILLER              PICTURE X(07)   VALUE 'MESSAGE'.
001610  02 FILLER              PICTURE X(22)   VALUE SPACES.
001620  02 FILLER              PICTURE X(16)   VALUE 'FROM--CONN  GA  '.
001630  02 FILLER              PICTURE X(16)   VALUE 'TO----CONN  GA  '.
001640  02 FILLER              PICTURE X(14)   VALUE 'DRAWING---NO  '.
001650  02 FILLER              PICTURE X(16)   VALUE 'NOMENCLATURE    '.
001660  02 FILLER              PICTURE X(16)   VALUE '    WIRE NUMBER '.
001670 01  PRT-LIN.
001680   02  FILLER            PICTURE X(9)    VALUE '  RECORD '.
001690   02  MESSAG            PICTURE X(23).
001700   02  FILLER            PICTURE XX  VALUE SPACES.
001710   02  FR-C-P            PICTURE X(10).
001720   02  FILLER            PICTURE XX  VALUE SPACES.
001730   02  FR-G-P            PICTURE XX.
001740   02  FILLER            PICTURE XX  VALUE SPACES.
001750   02  TO-C-P            PICTURE X(10).
001760   02  FILLER            PICTURE XX  VALUE SPACES.
001770   02  TO-G-P            PICTURE XX.
001780   02  FILLER            PICTURE XX  VALUE SPACES.
001790   02  DWG-NP            PICTURE X(12).
001800   02  FILLER            PICTURE XX  VALUE SPACES.
001810   02  NOMENP            PICTURE X(18).
001820   02  FILLER            PICTURE XX  VALUE SPACES.
001830   02  WIRE-P            PICTURE X(14).
001840 01  PIN-FIELD.
001850  02 TYPE-ED             PICTURE X   OCCURS 10   TIMES.
001860  02 NOME-ED.
001870     03  NOM-E1          PICTURE X(5).
001880     03  FILLER          PICTURE X(13).
001890 01  LAST-LINE.
001900  02 FILLER              PICTURE X(30)   VALUE SPACES.
001910  02 FILLER              PICTURE X(05)   VALUE 'DATE '.
001920  02 DATE-2              PICTURE X(8).
001930  02 FILLER              PICTURE X(10)   VALUE SPACES.
001940  02 SP-CRT1             PICTURE X(15).
001950  02 FILLER              PICTURE X(10)   VALUE '     PAGE '.
001960  02 PAGE-1              PICTURE ZZ9.
001970 01  GROUP2.
001980   02  ARA   OCCURS  1000    TIMES.
001990       03    FR-CONA2        PICTURE X(10).
002000       03    TO-CONA2        PICTURE X(10).
002010       03    DWG-NOA2        PICTURE X(12).
002020       03    WIR-NOA2        PICTURE X(14).
002030       03    NOMEN-A2.
002040          04  FILLER         PICTURE X(17).
002050          04  DUP-A2         PICTURE X.
002060 01  AUX-HOLD.
002070  02 AUX-WIRE            PICTURE X(14).
002080  02 AUX-DWGN            PICTURE X(12).
002090  02 AUX-FROMC.
002100     03  PJ-TYP-F        PICTURE X.
002110     03  PJ-NUMBF        PICTURE X(4).
002120     03  PJ-ALPHAF       PICTURE X.
002130     03  PJ-PIN-F        PICTURE X(4).
002140  02 AUX-TOC.
002150     03  PJ-TYP-T        PICTURE X.
002160     03  PJ-NUMBT        PICTURE X(4).
002170     03  PJ-ALPHAT       PICTURE X.
002180     03  PJ-PIN-T        PICTURE X(4).
002190  02 AUX-NOMEN           PICTURE X(18).
002200 01  GROUP1.
002210   02  ARRAY1    OCCURS  1500    TIMES.
002220       03    PJ-NUMB-A       PICTURE X(4).
002230 01  TEMP-NO.
002240   02    NO-TP           PICTURE X(4).
002250   02    PJ-VAL          PICTURE X.
002260 01  TEMP-FR-TO-HLD.
002270   02    FR-OR-TO            PICTURE X(16).
002280 01  HEAD-1.
002290  02 FILLER              PICTURE X(5) VALUE SPACES.
002300  02 FILLER  PICTURE X(18) VALUE 'CAFROM-CONN--PIN  '.
002310  02 FILLER  PICTURE X(18) VALUE 'CA--TO-CONN--PIN  '.
002320  02 FILLER  PICTURE X(16) VALUE '  WIRE NUMBER   '.
002330  02 FILLER  PICTURE X(20) VALUE '   NOMENCLATURE     '.
002340  02 FILLER  PICTURE X(14) VALUE ' DWG NUMBER   '.
002350  02 FILLER  PICTURE X(09) VALUE 'REVERSE  '.
002360 01  T-W-LIN.
002370  02 FILLER              PICTURE X(5)  VALUE SPACES.
002380  02 FR-PRT              PICTURE X(16).
002390  02 FILLER              PICTURE XX    VALUE SPACES.
002400  02 TO-PRT              PICTURE X(16).
002410  02 FILLER              PICTURE XX    VALUE SPACES.
002420  02 WN-PRT              PICTURE X(14).
002430  02 FILLER              PICTURE XX    VALUE SPACES.
002440  02 NO-PRT              PICTURE X(18).
002450  02 FILLER              PICTURE XX    VALUE SPACES.
002460  02 DW-PRT              PICTURE X(12).
002470  02 FILLER              PICTURE XX    VALUE SPACES.
002480  02 DP-PRT              PICTURE X.
002490 01  FR-TO-MES.
002500   02    FR-MES          PICTURE XX.
002510   02    TO-MES          PICTURE XX.
002520 PROCEDURE DIVISION.
002530     OPEN INPUT  OPT-FLE.
002540     OPEN INPUT  GRUM-TP.
002550     OPEN OUTPUT AUX-STO.
002560     OPEN OUTPUT RPT-TP1.
002570     READ OPT-FLE INTO OPT-HLD AT END GO TO  PHAS2.
002580     NOTE    -------------------------------------------------
002590
002600             1-WAY -  ONE WAY GRUMMAN 655M LM MASTER
002610                   -  CONTROL IS PASSED TO PHAS1 SECTION
002620
002630             BLANK -  TWO WAY GRUMMAN 655M LM MASTER
002640                   -  CONTROL IS PASSED TO PHAS2 SECTION
002650
002660         -----------------------------------------------------.
002670     IF  OPT-1  = '1-WAY'    NEXT SENTENCE ELSE
002680                             GO TO PHAS2.
002690 PHAS1 SECTION.
002700 PRC-2.
002710     READ GRUM-TP    INTO    GRUM-HLD    AT  END
002720                             GO TO PHAS3.
002730     IF  FROM-C  =   SPACES   OR   TO-C  =  SPACES
002740             MOVE 'DELETED BLANK TYPE     '  TO MESSAG
002750             PERFORM WRITE-DEL  THRU  WRT-D-EX,
002760             GO  TO  PRC-2.
002770     MOVE    FR-HLD  TO  FR-TO.
002780     PERFORM   ED-FT     THRU    ED-FT-EX.
002790     MOVE    CONN-1  TO  AUX-FR
002800     MOVE    SPACES  TO  FR-TO       PIN-FIELD.
002810     IF  ILL-DAT  =  1       MOVE  0  TO   ILL-DAT
002820                             GO  TO  PRC-2.
002830     MOVE  TO-HLD    TO  FR-TO.
002840     PERFORM     ED-FT   THRU    ED-FT-EX.
002850     MOVE    CONN-1  TO  AUX-TO
002860     MOVE    SPACES  TO  FR-TO       PIN-FIELD.
002870         IF  ILL-DAT   =   1     MOVE  0   TO  ILL-DAT
002880                                 GO  TO  PRC-2.
002890     MOVE    DWG-HLD TO  AUX-DW
002900     MOVE    NOMEN-HLD TO  AUX-NO
002910     MOVE    WIRE-NO-HLD TO  AUX-WR.
002920     WRITE   TEMP.
002930     GO TO   PRC-2.
002940 PHAS2 SECTION.
002950 SORT-1.
002960     SORT   WIRE-S1  ON  ASCENDING KEY       WIRE-NOS1
002970                                             DWG-NOS1
002980                 FR-CONS1  TO-CONS1
002990         INPUT   PROCEDURE   PROC2A
003000         OUTPUT  PROCEDURE   PROC2B
003010     GO  TO  PHAS3.
003020 PROC2A SECTION.
003030 PRC-1.
003040     READ  GRUM-TP  INTO GRUM-HLD AT END GO TO PROC2A-EX.
003050     NOTE    -------------------------------------------------
003060
003070             FR-TO IS A COMMON HOLD AREA FOR OPERATION ON EITHER
003080             THE FROM OR TO CONNECTORS
003090
003100             ILL-DAT - A SWITCH USED AS A SIGNAL FOR LEGAL /
003110                       ILLEGAL DATA
003120                     = 1 ILLEGAL CONNECTOR AND THE PROPER MESSAG
003130                         E HAS BEEN PRINTED AND THE RECORD IS
003140                         DELETED
003150                     = 0 LEGAL DATA PROCEED WITH NORMAL PROCES-
003160                         SING
003170
003180         -----------------------------------------------------.
003190         IF  FROM-C  = SPACES    OR  TO-C    =   SPACES
003200             MOVE 'DELTD DUE TO BLNK FR/TO' TO MESSAG
003210             PERFORM WRITE-DEL THRU WRT-D-EX
003220                     GO TO   PRC-1.
003230         MOVE FR-HLD  TO  FR-TO.
003240         PERFORM ED-FT THRU ED-FT-EX.
003250         MOVE FR-TO   TO  FR-HLD.
003260         MOVE  SPACES  TO  FR-TO  PIN-FIELD.
003270         IF ILL-DAT  =  1    MOVE  0 TO  ILL-DAT  GO TO  PRC-1.
003280         MOVE TO-HLD    TO  FR-TO.
003290         PERFORM ED-FT  THRU  ED-FT-EX.
003300         MOVE FR-TO  TO  TO-HLD.
003310         MOVE SPACES  TO  FR-TO  PIN-FIELD.
003320         IF  ILL-DAT  =  1   MOVE  0  TO  ILL-DAT GO TO  PRC-1.
003330     MOVE GRUM-HLD TO SRT-F1.
003340     IF  FR-CONS1    =   TO-CONS1    PERFORM DEL-SECT
003350                                     GO  TO  PRC-1.
003360         MOVE SPACES TO  FR-GAUGS1, TO-GAUGS1.
003370     NOTE    -------------------------------------------------
003380
003390             FROM AND TO NO LONGER NEEDED AS TEST FOR SHIELDS
003400             HAS BEEN ACCOMPLISHED
003410
003420             ------------------------------------------------.
003430     RELEASE SRT-F1.
003440     GO TO PRC-1.
003450 PROC2A-EX.
003460     EXIT.
003470 PROC2B SECTION.
003480     MOVE 0  TO  I.
003490 PROC-2B.
003500     RETURN              WIRE-S1
003510                     AT  END MOVE  5  TO ALL-DONE
003520                     GO TO MATCH-2-WAY.
003530     IF  I   =  0                MOVE  1  TO  I, K
003540             PERFORM MOV-ARA,
003550             GO  TO  PROC-2B.
003560     IF  DWG-NOS1    =   DWG-NOA2 (I)
003570                 COMPUTE  I = I + 1      PERFORM  I-CHECK
003580                 PERFORM MOV-ARA
003590                 GO  TO  PROC-2B.
003600 MATCH-2-WAY.
003610     MOVE 1  TO  K.
003620     MOVE 2  TO  J.
003630     PERFORM  DEL-DUPLICATE  THRU  DUP-EXIT.
003640 LOOP-2-WAY.
003650     IF  DUP-A2 (K)  =   '*'     GO  TO  ADD-KJ.
003660 CK-FRS.
003670     IF  FR-CONA2 (K)    =   TO-CONA2 (J)        AND
003680         TO-CONA2 (K)    =   FR-CONA2 (J)        AND
003690         WIR-NOA2 (K)    =   WIR-NOA2 (J)
003700             MOVE '*'    TO  DUP-A2 (J)
003710             GO  TO  ADD-KJ.
003720     NOTE    -------------------------------------------------
003730
003740             A SEGMENT MUST HAVE A REVERSE   IF NOT THAT
003750                 SEGMENT IS DELETED  OTHERWISE MARK  DUP-A2 (J)
003760                 WITH AN '*'
003770             REVERSE SEGMENTS ARE DELETED IN ORDER TO REDUCE
003780                 THE DATA BASE SIZE FOR ARRAY STORAGE IN THE
003790                 HANDLING OF 'P' AND 'J' TYPE SEGMENTS
003800
003810         -----------------------------------------------------.
003820     COMPUTE J = J + 1.
003830     IF  J   >   I
003840     MOVE  'DELTD NO REVERSE FOUND '  TO  MESSAG
003850     PERFORM  ARRAY-TO-BUFF
003860         PERFORM     WRITE-DEL   THRU    WRT-D-EX
003870         PERFORM     BLNK-ARA
003880         GO  TO  ADD-KJ.
003890     GO  TO  CK-FRS.
003900 ADD-KJ.
003910     COMPUTE  K = K + 1.
003920     COMPUTE  J =   K + 1.
003930     IF  K   >   I   NEXT  SENTENCE  ELSE
003940                     GO  TO  LOOP-2-WAY.
003950 WRT-ARRAY.
003960     MOVE  1   TO  K.
003970 WRT-LOP.
003980     IF  FR-CONA2 (K)  =  SPACES     OR  DUP-A2 (K)  =  '*'
003990             COMPUTE  K = K + 1      GO  TO  CK-K-WRT.
004000     PERFORM ARRA-WRT.
004010     COMPUTE K = K + 1.
004020 CK-K-WRT.
004030     IF  K  >  I                 MOVE  1 TO K
004040             GO  TO  DONE-ALL.
004050     GO  TO  WRT-LOP.
004060 BLNK-ARA.
004070     MOVE SPACES TO  FR-CONA2 (K).
004080     MOVE SPACES TO  TO-CONA2 (K).
004090     MOVE SPACES TO  DWG-NOA2 (K).
004100     MOVE SPACES TO  WIR-NOA2 (K).
004110     MOVE SPACES TO  NOMEN-A2 (K).
004120 BLNK-ARA-1.
004130     COMPUTE K = K + 1.
004140     IF  K   >   1000    GO  TO  BLNK-EX.
004150     GO  TO  BLNK-ARA.
004160 BLNK-EX.
004170     EXIT.
004180 MOV-ARA.
004190     MOVE    FR-CONS1    TO  FR-CONA2 (I).
004200     MOVE    TO-CONS1    TO  TO-CONA2 (I).
004210     MOVE    DWG-NOS1    TO  DWG-NOA2 (I).
004220     MOVE    WIRE-NOS1   TO  WIR-NOA2 (I).
004230     MOVE    NOMEN-S1    TO  NOMEN-A2 (I).
004240 I-CHECK.
004250     IF   I   >  1000
004260             DISPLAY ' NEED MORE DWG/WIRE/ ARA SPACE '
004270             CLOSE  OPT-FLE
004280             CLOSE  AUX-STO
004290             CLOSE  GRUM-TP
004300             CLOSE  RPT-TP1
004310             STOP RUN.
004320 ARRA-WRT.
004330     MOVE    FR-CONA2 (K)  TO    AUX-FR.
004340     MOVE    TO-CONA2 (K)  TO    AUX-TO.
004350     MOVE    DWG-NOA2 (K)  TO    AUX-DW.
004360     MOVE    WIR-NOA2 (K)  TO    AUX-WR.
004370     MOVE    NOMEN-A2 (K)  TO    AUX-NO.
004380     WRITE   TEMP.
004390 ARRA-WRT-EX.
004400     EXIT.
004410 DONE-ALL.
004420     IF  ALL-DONE  =  5  GO TO   PROC2B-EX.
004430             MOVE 1  TO  I.
004440             PERFORM MOV-ARA.
004450             GO  TO  PROC-2B.
004460 PROC2B-EX.
004470     EXIT.
004480 PHAS3 SECTION.
004490     CLOSE   OPT-FLE.
004500     CLOSE   AUX-STO.
004510 SORT-2.
004520     SORT    WIRE-S2  ON  ASCENDING  KEY
004530                 FROM-CONT       TO-CONT
004540             INPUT   PROCEDURE   PHAS3A
004550             GIVING  SRT2WAY.
004560     NOTE    -------------------------------------------------
004570
004580         OPT-2  = 'YES'  PRINT PREPROCESSED  2-WAY GRUMMAN
004590             LM  RECORDS FOR (SP-CRT) THIS SPACE CRAFT ON THIS
004600             DAY (DATE-1)    OTHERWISE   PROCESSING IS STOPPED
004610
004620         -----------------------------------------------------.
004630     IF  OPT-2   =   'YES'       GO  TO  WRT-MST-FLE.
004640                     GO  TO  STOP-RUN.
004650 PHAS3A SECTION.
004660     OPEN    INPUT   AUX-STO.
004670     MOVE  0  TO  J.
004680 PRC-3.
004690     READ AUX-STO INTO   AUX-HOLD  AT END
004700                             CLOSE AUX-STO
004710                             OPEN INPUT AUX-STO
004720                             MOVE  1  TO  I
004730                             GO  TO  FINAL-STEP.
004740     IF  PJ-TYP-F  =  'P'    NEXT SENTENCE   ELSE  GO TO TO-SIDE.
004750     NOTE    -------------------------------------------------
004760
004770         BOTH FROM AND TO MUST BE CHECKED FOR A  'P' TYPE
004780             NON-ALPHA ENDING CHARACTER
004790                     EXAMPLE  P0123      P TYPE  NON ALPHA END
004800                              P0123A     P TYPE  ALPHA END
004810         AN ARRAY OF 'P' TYPE NON-ALPHA (NUMERIC 4 CHARACTERS
004820             ONLY) CONSTRUCTED AND USED  AS A REFERENCE FOR
004830             'J' TYPE NON-ALPHA
004840         IF A MATCH IS FOUND J CHANGED TO P
004850
004860         -----------------------------------------------------.
004870     IF  PJ-ALPHAF =  SPACES NEXT   SENTENCE ELSE  GO TO TO-SIDE.
004880         MOVE    PJ-NUMBF  TO  NO-TP.
004890         PERFORM LK-UP   THRU  LK-UP-EX.
004900 TO-SIDE.
004910     IF  PJ-TYP-T  =  'P'    NEXT SENTENCE   ELSE
004920                             GO  TO  PRC-3.
004930     IF  PJ-ALPHAT NOT =   SPACES    GO  TO  PRC-3.
004940         MOVE    PJ-NUMBT    TO  NO-TP.
004950         PERFORM LK-UP   THRU  LK-UP-EX.
004960         GO  TO  PRC-3.
004970 LK-UP.
004980     MOVE  1  TO  I.
004990 LOOP-PROC.
005000     IF  NO-TP   =   PJ-NUMB-A (I)
005010                     MOVE    SPACES  TO  TEMP-NO
005020                     GO  TO  LK-UP-EX.
005030     COMPUTE I = I + 1.
005040     IF  I  >  J
005050                 COMPUTE  J =  J + 1
005060                 MOVE NO-TP  TO  PJ-NUMB-A (J)
005070                 MOVE SPACES TO  TEMP-NO
005080                 GO  TO  LK-UP-EX.
005090     GO  TO  LOOP-PROC.
005100 LK-UP-EX.
005110     EXIT.
005120 FINAL-STEP.
005130     MOVE    SPACES  TO    FR-TO-MES.
005140     READ  AUX-STO   INTO    AUX-HOLD  AT END
005150                             CLOSE AUX-STO
005160                             GO TO   PHAS3A-EX.
005170     IF  PJ-TYP-F  =  'J'    NEXT SENTENCE   ELSE
005180                             GO  TO  TO-TYPEX.
005190     IF  PJ-ALPHAF  NOT =  SPACES    GO  TO  TO-TYPEX.
005200     MOVE    PJ-NUMBF   TO   NO-TP.
005210         MOVE  1  TO  I.
005220         MOVE  SPACES  TO  PJ-VAL.
005230     PERFORM     FIND-1  THRU  FIND-DONE.
005240     IF  PJ-VAL  =   'P'
005250     MOVE   'FR'      TO    FR-MES.
005260 TO-TYPEX.
005270     IF  PJ-TYP-T =   'J'    NEXT SENTENCE   ELSE
005280                             GO  TO  CHG-FR-PJ.
005290     IF  PJ-ALPHAT   NOT  =   SPACES     GO  TO  CHG-FR-PJ.
005300     MOVE  SPACES  TO  PJ-VAL.
005310     MOVE    PJ-NUMBT   TO   NO-TP.
005320     MOVE    1   TO  I.
005330     PERFORM     FIND-1  THRU    FIND-DONE.
005340     IF  PJ-VAL  =   'P'
005350     MOVE    'TO'    TO   TO-MES.
005360 CHG-FR-PJ.
005370     IF  FR-TO-MES   =  SPACES    GO  TO  WRITE-2-WAY.
005380     IF  FR-TO-MES  =   'FRTO'
005390             MOVE    'CHNG FR/TO FR J TO P(N)' TO MESSAG
005400             PERFORM MOV-BUFF
005410             PERFORM WRITE-DEL THRU  WRT-D-EX
005420             MOVE 'P'    TO  PJ-TYP-F
005430             MOVE 'P'    TO  PJ-TYP-T
005440             GO  TO  WRITE-2-WAY.
005450     IF  FR-TO-MES  =  'FR  '
005460             MOVE    'CHNG FROM  FR J TO P(N)' TO MESSAG
005470             PERFORM MOV-BUFF
005480             PERFORM WRITE-DEL THRU  WRT-D-EX
005490             MOVE 'P'    TO  PJ-TYP-F
005500             GO  TO  WRITE-2-WAY.
005510         MOVE   'CHNG  TO   FR J TO P(N)' TO MESSAG.
005520         PERFORM MOV-BUFF
005530         PERFORM WRITE-DEL  THRU  WRT-D-EX.
005540         MOVE 'P'   TO  PJ-TYP-T.
005550     GO TO   WRITE-2-WAY.
005560 FIND-1.
005570     IF  NO-TP   =   PJ-NUMB-A (I)
005580                 MOVE 'P'  TO    PJ-VAL
005590                 GO  TO  FIND-DONE.
005600     COMPUTE I = I + 1.
005610     IF  I  >   J
005620                 MOVE 'J'  TO    PJ-VAL
005630                 MOVE 1  TO  I,
005640                 GO  TO FIND-DONE.
005650     GO TO   FIND-1.
005660 FIND-DONE.
005670     EXIT.
005680 WRITE-2-WAY.
005690     MOVE SPACES TO  SRT-F2.
005700     MOVE  'G'   TO  CONTRACTOR-F    CONTRACTOR-T
005710     MOVE  'L'   TO  AREA-CD-F       AREA-CD-T
005720     MOVE  PJ-TYP-F    TO    PJ-FROM
005730     MOVE  PJ-NUMBF    TO    NUMBER-TYP-F
005740     MOVE  PJ-ALPHAF   TO    ALPHA-FR
005750     MOVE  PJ-PIN-F    TO    PIN-NO-F
005760     MOVE  PJ-TYP-T    TO    PJ-TO-S2
005770     MOVE  PJ-NUMBT    TO    NUMBER-TYP-T
005780     MOVE  PJ-ALPHAT   TO    ALPHA-TO
005790     MOVE  PJ-PIN-T    TO    PIN-NO-T
005800     MOVE  AUX-WIRE    TO    WIRE-NO-S2
005810     MOVE  AUX-NOMEN   TO    NOMEN-S2
005820     MOVE  AUX-DWGN    TO    DROW-NO
005830     MOVE  SPACES      TO    DUPLICATE-S2.
005840     RELEASE SRT-F2.
005850     NOTE    -------------------------------------------------
005860
005870         ORIGIONAL SEGMENT - DUPLICATE-S2 = SPACES IS RELEASED
005880             TO INTERNAL SORT        THEN
005890         FROM AND TO CONNECTORS  ARE FLIPPED  AND
005900             DUPLICATE-S2 = '*'  AND THEN THE    REVERSE
005910             IS RELEASED TO  THE SORT
005920
005930         -----------------------------------------------------.
005940     MOVE SPACES TO FR-OR-TO.
005950     MOVE    FROM-CONT   TO  FR-OR-TO.
005960     MOVE SPACES TO FROM-CONT.
005970     MOVE    TO-CONT     TO  FROM-CONT.
005980     MOVE SPACES TO TO-CONT.
005990     MOVE    '*'     TO      DUPLICATE-S2.
006000     MOVE    FR-OR-TO    TO  TO-CONT.
006010     RELEASE SRT-F2.
006020     GO  TO  FINAL-STEP.
006030 PHAS3A-EX.
006040     EXIT.
006050 WRT-MST-FLE SECTION.
006060     OPEN INPUT  SRT2WAY.
006070     NOTE    -------------------------------------------------
006080
006090         THIS SECTION IS PERFORMED ONLY IF   OPT-2 = 'YES'
006100
006110         -----------------------------------------------------.
006120     MOVE 45 TO  LIN-CT.
006130     MOVE  0  TO PG-CT
006140     GO  TO  PG-EJECT-2.
006150 INPUT-S2.
006160     READ    SRT2WAY  AT END     CLOSE   SRT2WAY
006170                                 GO TO   STOP-RUN.
006180     MOVE    FR-CONN              TO FR-PRT.
006190     MOVE    TO-CONN              TO TO-PRT.
006200     MOVE    REF-DESS2-WIRE-NO    TO WN-PRT.
006210     MOVE    NOMENS2              TO NO-PRT.
006220     MOVE    DRAWING-S2           TO DW-PRT.
006230     MOVE    DUPS2                TO DP-PRT.
006240     WRITE   MESSAGX     FROM  T-W-LIN AFTER 1.
006250     ADD  1  TO   LIN-CT.
006260     IF  LIN-CT  >   45  GO  TO  PG-EJECT-2.
006270                     GO  TO  INPUT-S2.
006280 PG-EJECT-2.
006290     MOVE  4  TO  LIN-CT.
006300     WRITE   MESSAGX  FROM LINER  AFTER      2.
006310     WRITE   MESSAGX  FROM   LAST-LINE   AFTER 1.
006320     WRITE   MESSAGX  FROM   LINER   AFTER 0.
006330     WRITE   MESSAGX  FROM   LINER   AFTER 2.
006340     WRITE   MESSAGX  FROM   HEAD-1  AFTER 1.
006350             WRITE MESSAGX FROM LINER AFTER 2
006360     ADD  1  TO  PG-CT
006370     MOVE    PG-CT  TO   PAGE-1.
006380     GO  TO  INPUT-S2.
006390 STOP-RUN.
006400     CLOSE   GRUM-TP.
006410     CLOSE   RPT-TP1.
006420     STOP RUN.
006430 ED-FT.
006440     PERFORM END-CAP     THRU END-CAP-EX.
006450     NOTE    -------------------------------------------------
006460
006470         THE TEST FOR    END CAPS
006480                         /SH         -   SHIELD
006490                         /SHL        -   SHIELD
006500                         /SHLD       -   SHIELD
006510                         TYPE SIZE   MAX 6 CHARACTERS
006520                         PIN SIZE    MAX 4 CHARACTERS
006530                                 TOTAL   10 CHARACTERS
006540         IF ILL-DAT  =  1    TEST FAILED     DATA SEGMENT IS
006550                                             DELETED AND PROCES
006560                                             SING CONTINUES
006570                                             WITH A NEW RECORD
006580
006590         -----------------------------------------------------.
006600     IF  ILL-DAT    =  1         PERFORM WRITE-DEL  THRU WRT-D-EX
006610                                 GO TO  ED-FT-EX.
006620     PERFORM SHIELDS     THRU SHIELDS-EX.
006630     IF  ILL-DAT    =  1         PERFORM WRITE-DEL  THRU WRT-D-EX
006640                                 GO TO  ED-FT-EX.
006650     PERFORM TYP-PIN-SIZ THRU TYP-PIN-SIZ-EX.
006660     IF  ILL-DAT    =   1        PERFORM WRITE-DEL  THRU WRT-D-EX
006670                                 GO TO  ED-FT-EX.
006680     PERFORM ED-PJ   THRU  ED-PJ-EX.
006690     IF  ILL-DAT   =  1      PERFORM WRITE-DEL  THRU WRT-D-EX.
006700 ED-FT-EX.
006710     EXIT.
006720 END-CAP.
006730 END-1.
006740     IF  CON-2 (1)    =  SPACES
006750                     MOVE 1 TO ILL-DAT
006760                     MOVE SPACES TO MESSAG
006770                     MOVE 'DELETED DUE TO BLANK CH' TO MESSAG
006780                     GO TO END-CAP-EX.
006790     NOTE    -------------------------------------------------
006800
006810         CHECK FIRST CHARACTER OF CONNECTOR IF IT IS = SPACES
006820             ILLEGAL SEGMENT EXIST   IF NOT
006830             END CAP CHECK IS MADE
006840
006850         -----------------------------------------------------.
006860     IF  TF-TYP       =  'END CA'
006870                     MOVE 1 TO ILL-DAT
006880                     MOVE SPACES TO MESSAG
006890                     MOVE 'DELETED DUE TO END CAP ' TO MESSAG.
006900 END-CAP-EX.
006910     EXIT.
006920 SHIELDS.
006930     MOVE  0  TO  SWT1.
006940     MOVE  1  TO  I.
006950 SHLD-1.
006960     IF  CON-2 (I)   NOT  =  '/'     NEXT SENTENCE  ELSE
006970                                     GO  TO  SHLD-TSTS.
006980     NOTE    -------------------------------------------------
006990
007000         AFTER THE FIRST '/' IS FOUND CONTROL IS SENT TO THE
007010             SHIELD TEST
007020         THE TOTAL FIELD (TYPE AND PIN)  MUST BE CHECKED
007030             INCLUDING THE GAUGE FIELD
007040
007050         -----------------------------------------------------.
007060         COMPUTE  I = I  + 1
007070         IF  I     >     10  GO  TO  SHIELDS-EX.
007080         GO  TO  SHLD-1.
007090 SHLD-TSTS.
007100     COMPUTE I = I + 1.
007110     IF I   >    10  GO  TO TST-GAUG.
007120     IF  CON-2 (I)  = 'S'    NEXT SENTENCE   ELSE
007130
007140                             GO  TO SHLD-1.
007150             MOVE 1 TO  SWT1.
007160     COMPUTE I = I + 1.
007170     IF  I   >   10  GO  TO  TST-GAUG.
007180     IF  CON-2 (I) =  'H'        MOVE 1 TO ILL-DAT MOVE 0 TO SWT1
007190                     MOVE 'DELETED DUE TO /SHLD   ' TO MESSAG
007200                     GO TO   SHIELDS-EX.
007210         MOVE 0 TO SWT1.
007220         GO TO   SHLD-1.
007230 TST-GAUG.
007240     IF SWT1 =  0    GO TO SH-GAUG.
007250     IF G-1 =  'H'   MOVE  1 TO  ILL-DAT  MOVE 0  TO SWT1
007260                     MOVE 'DELETED DUE TO SHLD H G' TO MESSAG.
007270             GO  TO  SHIELDS-EX.
007280 SH-GAUG.
007290     IF G-1 =  'S'   NEXT SENTENCE ELSE GO TO SHIELDS-EX.
007300     IF G-2 =  'H'   NEXT SENTENCE ELSE GO TO SHIELDS-EX.
007310             MOVE 1 TO   ILL-DAT     MOVE  0  TO  SWT1
007320             MOVE 'DELETED DUE TO SHLD SHG'  TO MESSAG.
007330 SHIELDS-EX.
007340     EXIT.
007350 TYP-PIN-SIZ.
007360     MOVE  1  TO  J.
007370     NOTE    -------------------------------------------------
007380
007390         THE FROM AND TO CONNECTORS ARE  BROKEN INTO
007400             TYPE AND PIN FIELDS WITHIN  EACH
007410         TYPE FIELD  =  6 MAX CHARACTERS
007420         PIN  FIELD  =  4 MAX CHARACTERS
007430             ALL SPECIAL CHARACTERS ARE  DELETED EXCEPT IN P
007440             AND J TYPES  WHERE  PERIODS  ARE KEPT IN ORDER
007450             TO DEFINE LOWER CASE PIN FIELDS
007460         THE FIRST SPECIAL CHARACTER ACTS AS THE TYPE 1 PIN
007470             FIELD SEPERATOR  IT  IS ALSO  DELETED
007480         EXAMPLE
007490         10MT1-A     =   10MT1 000A
007500         0J12/AA     =   J0012 00AA
007510
007520         -----------------------------------------------------.
007530     MOVE  0  TO  I.
007540 TYP-PIN-1.
007550     COMPUTE I  = I + 1.
007560     IF  CON-2 (I) = SPACE   OR = '/'    OR = '-'    OR = '.'
007570                             OR = ','
007580             MOVE SPACES TO  PIN-FIELD
007590             GO  TO  PIN-ANA.
007600     IF  I >  6
007610             MOVE 1 TO  ILL-DAT
007620             MOVE 'DELTD DUE TO LARGE TYPE' TO MESSAG
007630             GO  TO  TYP-PIN-SIZ-EX.
007640     GO  TO  TYP-PIN-1.
007650  PIN-ANA.
007660     MOVE SPACES TO  CON-2 (I).
007670     COMPUTE I = I + 1.
007680     IF  I  >  10
007690             MOVE  10  TO  I
007700             GO  TO  MOV-PIN.
007710     IF  CON-2 (I) = '/' OR = '-' OR = ','   OR = '.'
007720                 GO  TO  FRSTPJ.
007730     IF  CON-2 (I) = SPACES      GO  TO  PJ-SP-PIN.
007740             GO  TO  MOVE-TEMP.
007750 PJ-SP-PIN.
007760     IF  CON-2 (1)  = 'P'  OR =  'J'  NEXT  SENTENCE  ELSE
007770                 GO  TO  PIN-ANA.
007780 LOOP-SP-PJ.
007790     COMPUTE  I  =  I  +  1.
007800     IF  I   >   10          MOVE  10  TO  I
007810                             GO  TO  MOV-PIN.
007820     IF  CON-2 (I)   NOT  =  SPACES
007830                     GO  TO  SP-PIN-PJ.
007840         GO  TO  LOOP-SP-PJ.
007850 FRSTPJ.
007860     IF  CON-2 (1) =  'P'  OR  =  'J'
007870                     NEXT SENTENCE   ELSE GO TO  PIN-ANA.
007880     IF  CON-2 (I)  =  '.'       GO  TO  MOVE-TEMP.
007890 SP-PIN-PJ.
007900         MOVE    'DELTD ILL CHAR P/J PIN '  TO MESSAG.
007910         MOVE 1  TO ILL-DAT.
007920         GO  TO  TYP-PIN-SIZ-EX.
007930 MOVE-TEMP.
007940     MOVE CON-2 (I)  TO  TYPE-ED (J).
007950     COMPUTE J = J + 1.
007960     GO TO   PIN-ANA.
007970 MOV-PIN.
007980     COMPUTE J = J - 1.
007990     IF  J  >   4
008000             MOVE  1 TO  ILL-DAT
008010             MOVE 'DELETED - PIN TO LARGE ' TO MESSAG
008020             GO TO TYP-PIN-SIZ-EX.
008030 TST-J-CT.
008040     IF  J  >   0
008050         MOVE  TYPE-ED (J) TO  CON-2 (I)
008060         COMPUTE I = I - 1
008070         COMPUTE J = J - 1
008080         GO TO   TST-J-CT.
008090 TST-I-CT.
008100     IF  I  >   6    NEXT SENTENCE   ELSE MOVE SPACE TO PIN-FIELD
008110                 GO  TO  SPARE-TST.
008120     IF  PIN-FIELD   =   SPACES
008130                 GO  TO  SPARE-TST.
008140     MOVE '0'  TO CON-2  (I).
008150     COMPUTE I  = I - 1.
008160     GO TO TST-I-CT.
008170 SPARE-TST.
008180     MOVE NOMEN-HLD          TO  NOME-ED.
008190     IF  NOM-E1  =  'SPARE'
008200             MOVE I  TO  ILL-DAT
008210             MOVE 'DELETED - SPARE IN NOME'      TO MESSAG.
008220 TYP-PIN-SIZ-EX.
008230     EXIT.
008240 WRITE-DEL.
008250     ADD 1 TO    LIN-CT.
008260     IF  LIN-CT  > 44
008270             MOVE 4 TO LIN-CT
008280             WRITE  MESSAGX  FROM LINER  AFTER 2
008290             WRITE  MESSAGX  FROM LAST-LINE AFTER 1
008300             WRITE  MESSAGX  FROM LINER  AFTER 0
008310             WRITE  MESSAGX  FROM LINER  AFTER 2
008320             WRITE  MESSAGX  FROM HEADER1 AFTER 1
008330             WRITE MESSAGX FROM LINER AFTER 2
008340             MOVE  DATE-1  TO  DATE-2
008350             MOVE  SP-CRT  TO  SP-CRT1
008360             ADD 1 TO PG-CT
008370             MOVE     PG-CT  TO  PAGE-1.
008380     MOVE   FROM-C   TO  FR-C-P.
008390     MOVE FR-GAUGE   TO  FR-G-P.
008400     MOVE   TO-C     TO  TO-C-P.
008410     MOVE TO-GAUGE   TO  TO-G-P.
008420     MOVE   DWG-NO   TO  DWG-NP.
008430     MOVE   NOMEN    TO  NOMENP.
008440     MOVE WIRE-NO    TO  WIRE-P.
008450     WRITE   MESSAGX   FROM  PRT-LIN  AFTER 1.
008460 WRT-D-EX.
008470     EXIT.
008480 ED-PJ.
008490     IF  CON-2 (6)   =   SPACES
008500                     NEXT SENTENCE   ELSE
008510             GO  TO  PJ-CK-6.
008520     IF  CON-2 (1)   =   'E'  OR =  'S'  OR = 'J' OR = 'P'
008530                     GO  TO XPROC-PJES.
008540     IF  CON-2 (2)   =   'S'     GO  TO XPROC-PJES.
008550     IF  CON-2 (3)   =   'S'     GO  TO XPROC-PJES.
008560                     GO  TO  ED-PJ-EX.
008570 XPROC-PJES.
008580     MOVE  1  TO  I   J.
008590 LOOP-PJ.
008600     MOVE  CON-2 (I)  TO  TYPE-ED (I).
008610     COMPUTE  I  =  I  +  1.
008620     IF  I   >     10     MOVE  1  TO  I
008630                          GO  TO  LOOP-PJ-1.
008640     GO  TO  LOOP-PJ.
008650 LOOP-PJ-1.
008660     IF  CON-2 (1)  =  'P'   OR = 'J' OR =   'E'
008670                     GO  TO  PROC-PJE.
008680     IF  CON-2 (1)  =  'S'
008690                     MOVE  '1'   TO  CON-2 (1)
008700             MOVE 'CHANGED TO NUMERIC S   '  TO  MESSAG
008710             PERFORM  WRITE-DEL  THRU  WRT-D-EX
008720                     GO  TO  SKIP-PJ.
008730     NOTE    -------------------------------------------------
008740
008750         S   TYPES  ARE  CHANGED TO  IS  (NUMERIC 1)S
008760             NO LONGER A SWITCH
008770         1S, 11S  (NUMERIC S)  ARE CHANGED TO
008780             S11S (S NUMERIC S)  THESE ARE SWITCHES
008790
008800         -----------------------------------------------------.
008810     MOVE 'S'    TO  CON-2 (1).
008820             MOVE 'CHANGED TO S NUMERIC S '  TO  MESSAG
008830             PERFORM WRITE-DEL   THRU  WRT-D-EX.
008840 SKIP-PJ.
008850     COMPUTE I = I + 1.
008860 MOVE-SS.
008870     MOVE    TYPE-ED (J)  TO     CON-2 (I).
008880     COMPUTE J = J + 1.
008890     COMPUTE I = I + 1.
008900     IF  J   >   6       GO  TO  ED-PJ-EX.
008910     IF  TYPE-ED (J)  =  SPACES
008920                         GO  TO  ED-PJ-EX.
008930     GO TO   MOVE-SS.
008940 PROC-PJE.
008950     MOVE  6  TO  J.
008960 LOOP-PJ1.
008970     IF  CON-2 (J)   =   SPACES
008980                 COMPUTE   J  =  J  - 1
008990                 GO  TO  LOOP-PJ1.
009000     IF  CON-2 (J)  IS   ALPHABETIC      NEXT SENTENCE   ELSE
009010                                         MOVE  5  TO  I
009020                                         GO  TO  LOOP-PJ2.
009030             MOVE  6  TO  I.
009040 LOOP-PJ2.
009050     MOVE  TYPE-ED (J) TO    CON-2 (I).
009060     COMPUTE     J   =   J - 1.
009070     COMPUTE     I   =   I - 1.
009080     IF  J   >   1   GO  TO  LOOP-PJ2.
009090 LOOP-PJ3.
009100     IF  I   >   1
009110                 MOVE    '0'   TO    CON-2 (I)
009120                 COMPUTE  I  =  I  - 1
009130                 GO  TO  LOOP-PJ3.
009140     MOVE  TYPE-ED (J)   TO  CON-2 (I).
009150     IF  TYPE-ED (I)   =  'E'
009160                         GO TO   ED-PJ-EX.
009170     IF CON-2 (7)    =   SPACES
009180             MOVE 'HAS BLANK PIN FIELD P/J'  TO  MESSAG
009190             MOVE  1  TO  ILL-DAT
009200             GO  TO  ED-PJ-EX.
009210 PJ-CK-6.
009220     IF  CON-2 (1)     =  'P'
009230                         NEXT SENTENCE ELSE
009240                         GO  TO  J-X-TYP.
009250     NOTE    -------------------------------------------------
009260
009270         P(NUMERIC)B ITEM TYPES WILL BE CHANGED TO P(NUMERIC)A
009280             P0089B  =   P0089A
009290         ITEMS OF TYPE P(NUMERIC) ALPHA, WHERE ALPHA IS A LETTER
009300             OTHER THAN B, AND ITEMS OF TYPE J(NUMERIC) ALPHA
009310             WHERE ALPHA IS A LETTER OTHER THAN X WILL NOT
009320             BE CHANGED
009330         J(NUMERIC)X  WILL BE CHANGED TO  P(NUMERIC)X
009340             J0026X-0002   =   P0026X-0002
009350
009360         -----------------------------------------------------.
009370     IF  CON-2 (6)     =  'B'
009380                     MOVE 'A'  TO  CON-2 (6)
009390             MOVE 'CHANGED TO -A- IN TYPE '  TO  MESSAG
009400             PERFORM WRITE-DEL    THRU   WRT-D-EX.
009410             GO  TO  ED-PJ-EX.
009420 J-X-TYP.
009430     IF  CON-2 (6)     =  'X'
009440                         NEXT SENTENCE ELSE
009450                         GO  TO  ED-PJ-EX.
009460     MOVE    'P'  TO  CON-2 (1).
009470     MOVE         'CHANGED TO  P-WAS J TYP'  TO  MESSAG
009480     PERFORM WRITE-DEL   THRU    WRT-D-EX.
009490 ED-PJ-EX.
009500     EXIT.
009510 DEL-SECT.
009520     MOVE  0  TO  ILL-DAT  SWT1
009530     MOVE         'DELETED FROM-TO  EQUAL '  TO MESSAG
009540             PERFORM WRITE-DEL     THRU WRT-D-EX
009550     MOVE   1  TO  ILL-DAT.
009560 DEL-SECT-EX.
009570     EXIT.
009580 MOV-BUFF.
009590     MOVE  AUX-FROMC   TO       FROM-C
009600     MOVE  AUX-TOC     TO       TO-C
009610     MOVE  AUX-DWGN    TO       DWG-NO
009620     MOVE  AUX-WIRE    TO       WIRE-NO
009630     MOVE  AUX-NOMEN   TO       NOMEN.
009640 MOV-BUFF-EX.
009650     EXIT.
009660 ARRAY-TO-BUFF.
009670         MOVE FR-CONA2 (K)   TO      FROM-C
009680         MOVE TO-CONA2 (K)   TO      TO-C
009690         MOVE DWG-NOA2 (K)   TO      DWG-NO
009700         MOVE WIR-NOA2 (K)   TO      WIRE-NO
009710         MOVE NOMEN-A2 (K)   TO      NOMEN.
009720 DEL-DUPLICATE.
009730     IF FR-CONA2 (K)   =   FR-CONA2 (J)     AND
009740         TO-CONA2 (K)  =  TO-CONA2 (J)     AND
009750         WIR-NOA2 (K)   =  WIR-NOA2 (J)     NEXT SENTENCE
009760             ELSE  GO  TO  COMP-J.
009770     MOVE  'DELTD DUPLICATE EXIST  '    TO  MESSAG.
009780         PERFORM   ARRAY-TO-BUFF.
009790         PERFORM  WRITE-DEL  THRU  WRT-D-EX.
009800         PERFORM  BLNK-ARA.
009810 COMP-K-J.
009820     COMPUTE  K  =  K  +  1.
009830     IF  K  >  I     GO  TO  DUP-EXIT-1.
009840     COMPUTE  J  =  K  +  1.
009850     IF  J  >  I    GO  TO  DUP-EXIT-1.
009860     GO  TO  DEL-DUPLICATE.
009870 COMP-J.
009880     COMPUTE  J  =  J  +  1.
009890     IF  J  >  I  NEXT  SENTENCE  ELSE
009900             GO  TO  DEL-DUPLICATE.
009910     GO  TO  COMP-K-J.
009920 DUP-EXIT-1.
009930     MOVE  1  TO  K.
009940     MOVE  2  TO  J.
009950 DUP-EXIT.
009960     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.      NRDGEN.
000030 AUTHOR.         LARRY J ROGOVEIN.
000040 INSTALLATION.   BOEING HOUSTON.
000050 DATE-WRITTEN.   MARCH 7, 1969.
000060 DATE-COMPILED.  JUNE 6,1969
000070 REMARKS.        THIS IS THE ASP NODE          REPORT DATA
000080                 GENERATION PROGRAM. THIS PROGRAM PROCESSES THE
000090                 INPUT MASTER BY
000100                  1) FLAGGING ALL INTERSECTION NODES AND ALL
000110                     SPECIAL NODES,
000120                  2) GENERATING A NODE REPORT DATA MASTER
000130                     CONTAINING ONLY THE FLAGGED NODES.
000140 ENVIRONMENT DIVISION.
000150 CONFIGURATION SECTION.
000160 SOURCE-COMPUTER. IBM-360.
000170 OBJECT-COMPUTER. IBM-360.
000180 INPUT-OUTPUT SECTION.
000190 FILE-CONTROL.
000200     SELECT PGIM ASSIGN TO UT-S-PGIMSTR.
000210     SELECT NRDM ASSIGN TO UT-S-NRDMSTR.
000220     SELECT AOFS ASSIGN TO UT-S-AOVFLST.
000230     SELECT IDSM ASSIGN TO UT-S-IDSMSTR.
000240     SELECT SORTF ASSIGN TO UT-S-SORTOUT.
000250 DATA DIVISION.
000260 FILE SECTION.
000270 FD  PGIM
000280     LABEL RECORD IS STANDARD
000290     RECORDING MODE IS F
000300     BLOCK CONTAINS 10 RECORDS
000310     RECORD CONTAINS 181 CHARACTERS
000320     DATA RECORD IS PGIM-REC.
000330 01  PGIM-REC.
000340   02  PATH-IN               PICTURE X(6).
000350     02  OTHER-DATA-IN       PICTURE X(175).
000360 FD  AOFS
000370     LABEL RECORD IS OMITTED
000380     RECORDING MODE IS F
000390     BLOCK CONTAINS  9 RECORDS
000400     RECORD CONTAINS 181 CHARACTERS
000410     DATA RECORD IS AOFS-REC.
000420 01  AOFS-REC                PICTURE X(181).
000430 FD  NRDM
000440     LABEL RECORD IS STANDARD
000450     RECORDING MODE IS F
000460     BLOCK CONTAINS 11 RECORDS
000470     RECORD CONTAINS 104 CHARACTERS
000480     DATA RECORD IS NRDM-REC.
000490 01  NRDM-REC.
000500     02  NRD-1T6             PICTURE X(6).
000510   02  NRD-7T12              PICTURE X(6).
000520   02  NRD-13                PICTURE X.
000530   02  NRD-14T28             PICTURE X(15).
000540   02  NRD-29T60.
000550     03  NRD-29T30           PICTURE XX.
000560     03  NRD-31T44           PICTURE X(14).
000570     03  NRD-45T46           PICTURE XX.
000580     03  NRD-47T60           PICTURE X(14).
000590   02  NRD-61T66             PICTURE X(6).
000600   02  NRD-67                PICTURE X.
000610   02  NRD-68T104            PICTURE X(37).
000620 FD  IDSM
000630     LABEL   RECORDS IS OMITTED
000640     RECORDING   MODE  IS  F
000650     BLOCK   CONTAINS  9 RECORDS
000660     RECORD  CONTAINS  181   CHARACTERS
000670     DATA  RECORD IS     IDSM-REC.
000680 01  IDSM-REC                PICTURE X(181).
000690 SD  SORTF
000700     RECORDING MODE IS F
000710     RECORD CONTAINS 181 CHARACTERS
000720     DATA RECORD IS SF.
000730 01  SF.
000740   02  SF-1T104.
000750     03  SF-1T6                PICTURE X(6).
000760     03  SF-7T12               PICTURE X(6).
000770     03  SF-13                 PICTURE X.
000780     03  SF-14T60.
000790       04  SF-14T18            PICTURE X(5).
000800       04  SF-19T30.
000810         15  SF-19T24          PICTURE X(6).
000820         05  SF-25T30          PICTURE X(6).
000830       04  SF-31T60            PICTURE X(30).
000840     03  SF-61T104             PICTURE X(44).
000850   02  SF-105T179              PICTURE X(75).
000860   02  SF-180                  PICTURE X.
000870   02  SF-181                  PICTURE X.
000880 WORKING-STORAGE SECTION.
000890 77  AOFS-STATUS             PICTURE 9.
000900 77  CHAR                    PICTURE X.
000910 77  CLOSED                  PICTURE 9       VALUE 0.
000920 77  COUNT                   PICTURE 9(6).
000930 77  DONE-FLAG               PICTURE 9.
000940 77  FIRST-NODE              PICTURE X(6).
000950 77  FLAG-OFF                PICTURE 9       VALUE 0.
000960 77  FLAG-ON                 PICTURE 9       VALUE 1.
000970 77  IINDEX                  PICTURE 999.
000980 77  MAX-REC                 PICTURE 999     VALUE 530.
000990 77  NO-NODES                PICTURE 999.
001000 77  NO-REC                  PICTURE 999.
001010 77  OPENED                  PICTURE 9       VALUE 1.
001020 77  OVERFLOW-COUNT          PICTURE 999.
001030 77  PASS-1                  PICTURE 9       VALUE 1.
001040 77  PASS-2                  PICTURE 9       VALUE 2.
001050 77  PASS-N                  PICTURE 9       VALUE 3.
001060 77  PASS-NO                 PICTURE 9.
001070 77  POS                     PICTURE 999.
001080 77  REC-NO                  PICTURE 999.
001090 77  SAVE-COUNT              PICTURE 999.
001100 77  TREE-NO                 PICTURE 9(6).
001110 77  TREE-NUM REDEFINES TREE-NO PICTURE X(6).
001120 77  TEST-NODE               PICTURE X(6).
001130 77  TEST-PATH               PICTURE X(6).
001140 77  TEST-TREE               PICTURE X(6).
001150 01  I-NODES-ARRAY.
001160   02  I-NODES                 PICTURE X(6)    OCCURS 999 TIMES.
001170 01  TREE-TABLE-ARRAY.
001180   02  TREE-TABLE              PICTURE X(6)    OCCURS 999 TIMES.
001190 01  WS-ARRAY.
001200   02  WS                                    OCCURS 530 TIMES.
001210     03  PATH-ELEM.
001220       04  PATH              PICTURE X(6).
001230       04  ELEM              PICTURE X(6).
001240         03  TREE            PICTURE X(6).
001250     03  F-NODE              PICTURE X(6).
001260     03  T-NODE              PICTURE X(6).
001270     03  OTHER-DATA.
001280       04  BOX-REF-DES       PICTURE X(15).
001290       04  BRANCH            PICTURE X(32).
001300       04  WS-78T81          PICTURE XXXX.
001310       04  AREA-HARNESS      PICTURE X(15).
001320       04  BED-RMK           PICTURE X(37).
001330       04  WS-134T141        PICTURE X(8).
001340       04  BID-RMK           PICTURE X(37).
001350       04  WS-179            PICTURE X.
001360     03  FLAG                PICTURE X.
001370     03  SWITCH              PICTURE X.
001380 PROCEDURE DIVISION.
001390 PROCEDURE DIVISION.
001400 INPUT-SORT SECTION.
001410     OPEN INPUT PGIM.
001420     OPEN OUTPUT IDSM.
001430     SORT SORTF ON ASCENDING KEY SF-25T30, SF-19T24,
001440         INPUT PROCEDURE PATH-EXTRACT THRU ASSIGN-TREE,
001450         OUTPUT PROCEDURE T-NODE-EXTRACT THRU LOAD-I-NODES.
001460     CLOSE PGIM, IDSM.
001470     GO TO PATH-REPORT-SORT.
001480 PATH-EXTRACT SECTION.
001490     DISPLAY 'ENTER INPUT-SORT INPUT PROCEDURE'.
001500     MOVE CLOSED TO AOFS-STATUS.
001510     MOVE FLAG-OFF TO DONE-FLAG.
001520     MOVE SPACES TO TEST-PATH, TEST-NODE.
001530     MOVE ZERO TO REC-NO, OVERFLOW-COUNT.
001540     MOVE 1 TO TREE-NO.
001550 READ-PGIM-LOOP.
001560     READ PGIM, AT END MOVE FLAG-ON TO DONE-FLAG,
001570                       GO TO OVERFLOW-TEST-1.
001580     IF TEST-PATH NOT EQUAL SPACES, GO TO NEW-PATH-TEST.
001590 PRIME-TEST-PATH.
001600     ALTER I-O-MODE TO PROCEED TO WRITE-DATA.
001610     IF AOFS-STATUS EQUAL OPENED,
001620             CLOSE AOFS,
001630             MOVE CLOSED TO AOFS-STATUS.
001640     MOVE PATH-IN TO TEST-PATH.
001650     GO TO STORE-REC-TEST-1.
001660 NEW-PATH-TEST.
001670     IF PATH-IN NOT EQUAL TEST-PATH, GO TO OVERFLOW-TEST-1.
001680 STORE-REC-TEST-1.
001690     ADD 1 TO REC-NO.
001700     IF REC-NO NOT GREATER THAN MAX-REC, GO TO STORE-REC-1.
001710     MOVE MAX-REC TO NO-REC.
001720     PERFORM ARRAY-OVERFLOW-RECOVERY.
001730     ADD 1 TO OVERFLOW-COUNT.
001740     MOVE 1 TO REC-NO.
001750 STORE-REC-1.
001760     MOVE PGIM-REC TO WS (REC-NO).
001770     GO TO READ-PGIM-LOOP.
001780 OVERFLOW-TEST-1.
001790     IF OVERFLOW-COUNT EQUAL ZERO, GO TO PATH-EXTRACT-EXIT.
001800     MOVE REC-NO TO NO-REC.
001810     PERFORM ARRAY-OVERFLOW-RECOVERY.
001820     ADD 1 TO OVERFLOW-COUNT.
001830 PATH-EXTRACT-EXIT.
001840     EXIT.
001850 ASSIGN-TREE SECTION.
001860     ALTER I-O-MODE TO PROCEED TO READ-DATA.
001870     IF AOFS-STATUS EQUAL OPENED,
001880             CLOSE AOFS,
001890             MOVE CLOSED TO AOFS-STATUS.
001900     MOVE PASS-1 TO PASS-NO.
001910     IF OVERFLOW-COUNT EQUAL ZERO, MOVE REC-NO TO NO-REC,
001920                                   GO TO START-TREE-ASSIGN.
001930 OVERFLOW-READ-LOOP-1.
001940     SUBTRACT 1 FROM OVERFLOW-COUNT.
001950     IF OVERFLOW-COUNT EQUAL ZERO,
001960             MOVE REC-NO TO NO-REC,
001970             PERFORM ARRAY-OVERFLOW-RECOVERY,
001980             GO TO ASSIGN-RELEASE.
001990     MOVE MAX-REC TO NO-REC.
002000     PERFORM ARRAY-OVERFLOW-RECOVERY.
002010     IF PASS-NO NOT EQUAL PASS-1, GO TO ASSIGN-RELEASE.
002020     MOVE PASS-N TO PASS-NO.
002030 START-TREE-ASSIGN.
002040     IF TEST-NODE EQUAL SPACES, GO TO PRIME-TEST-NODE-1.
002050     IF T-NODE (1) EQUAL TEST-NODE, GO TO ASSIGN-RELEASE.
002060     ADD 1 TO TREE-NO.
002070     IF TREE-NO GREATER THAN 999,
002080             DISPLAY 'MORE THAN 999 TREES FOUND.',
002090             STOP RUN.
002100 PRIME-TEST-NODE-1.
002110     MOVE T-NODE (1) TO TEST-NODE.
002120 ASSIGN-RELEASE.
002130     PERFORM ASSIGN-RELEASE-LOOP VARYING COUNT FROM 1 BY 1 UNTIL
002140             COUNT GREATER THAN NO-REC.
002150     GO TO DONE-TEST-1.
002160 ASSIGN-RELEASE-LOOP.
002170     MOVE TREE-NUM TO TREE (COUNT).
002180     MOVE WS (COUNT) TO SF.
002190     RELEASE SF.
002200 DONE-TEST-1.
002210     IF OVERFLOW-COUNT NOT EQUAL ZERO, GO TO OVERFLOW-READ-LOOP-1.
002220     IF DONE-FLAG EQUAL FLAG-ON, GO TO ASSIGN-TREE-EXIT.
002230     MOVE ZERO TO REC-NO.
002240     GO TO PRIME-TEST-PATH.
002250 ASSIGN-TREE-EXIT.
002260     EXIT.
002270 T-NODE-EXTRACT SECTION.
002280     DISPLAY 'ENTER INPUT-SORT OUTPUT PROCEDURE'.
002290     MOVE FLAG-OFF TO DONE-FLAG.
002300     MOVE SPACES TO TEST-NODE.
002310     MOVE ZEROS TO REC-NO, OVERFLOW-COUNT, NO-NODES.
002320 RETURN-INPUT-SORT-LOOP.
002330     RETURN SORTF, AT END MOVE FLAG-ON TO DONE-FLAG,
002340                   GO TO OVERFLOW-TEST-2.
002350     IF SF-180 EQUAL 'T', OR SF-25T30 EQUAL '000001' OR '000002',
002360             MOVE SF TO IDSM-REC,
002370             WRITE IDSM-REC,
002380             GO TO RETURN-INPUT-SORT-LOOP.
002390     IF TEST-NODE NOT EQUAL SPACES, GO TO NEW-NODE-TEST-2.
002400 PRIME-TEST-NODE-2.
002410     ALTER I-O-MODE TO PROCEED TO WRITE-DATA.
002420     IF AOFS-STATUS EQUAL OPENED,
002430             CLOSE AOFS,
002440             MOVE CLOSED TO AOFS-STATUS.
002450     MOVE SF-25T30 TO TEST-NODE.
002460     GO TO STORE-REC-TEST-2.
002470 NEW-NODE-TEST-2.
002480     IF SF-25T30 NOT EQUAL TEST-NODE, GO TO OVERFLOW-TEST-2.
002490 STORE-REC-TEST-2.
002500     ADD 1 TO REC-NO.
002510     IF REC-NO NOT GREATER THAN MAX-REC, GO TO STORE-REC-2.
002520     MOVE MAX-REC TO NO-REC.
002530     PERFORM ARRAY-OVERFLOW-RECOVERY.
002540     ADD 1 TO OVERFLOW-COUNT.
002550     MOVE 1 TO REC-NO.
002560 STORE-REC-2.
002570     MOVE SF TO WS (REC-NO).
002580     GO TO RETURN-INPUT-SORT-LOOP.
002590 OVERFLOW-TEST-2.
002600     IF OVERFLOW-COUNT EQUAL ZERO, GO TO T-NODE-EXTRACT-EXIT.
002610     MOVE REC-NO TO NO-REC.
002620     PERFORM ARRAY-OVERFLOW-RECOVERY.
002630     ADD 1 TO OVERFLOW-COUNT.
002640 T-NODE-EXTRACT-EXIT.
002650     EXIT.
002660 LOAD-I-NODES SECTION.
002670     ALTER I-O-MODE TO PROCEED TO READ-DATA.
002680     IF AOFS-STATUS EQUAL OPENED,
002690             CLOSE AOFS,
002700             MOVE CLOSED TO AOFS-STATUS.
002710     MOVE PASS-1 TO PASS-NO.
002720     IF OVERFLOW-COUNT EQUAL ZERO, MOVE REC-NO TO NO-REC,
002730                                   GO TO TERMINAL-NODE-TEST-2.
002740 OVERFLOW-READ-LOOP-2.
002750     SUBTRACT 1 FROM OVERFLOW-COUNT.
002760     IF OVERFLOW-COUNT EQUAL ZERO,
002770             MOVE REC-NO TO NO-REC,
002780             PERFORM ARRAY-OVERFLOW-RECOVERY,
002790             GO TO LAST-PASS-TEST.
002800     MOVE MAX-REC TO NO-REC.
002810     PERFORM ARRAY-OVERFLOW-RECOVERY.
002820     IF PASS-NO EQUAL PASS-1, MOVE PASS-2 TO PASS-NO,
002830                             GO TO TERMINAL-NODE-TEST-2.
002840 LAST-PASS-TEST.
002850     IF PASS-NO EQUAL PASS-N, GO TO GEN-IDSM.
002860     MOVE 1 TO COUNT.
002870     GO TO SECOND-F-NODE-TEST.
002880 TERMINAL-NODE-TEST-2.
002890     MOVE F-NODE (1) TO FIRST-NODE.
002900     MOVE 2 TO COUNT.
002910 SECOND-F-NODE-TEST.
002920     IF COUNT GREATER THAN NO-REC, GO TO GEN-IDSM.
002930     IF F-NODE (COUNT) EQUAL FIRST-NODE, ADD 1 TO COUNT,
002940                                         GO TO SECOND-F-NODE-TEST.
002950     ADD 1 TO NO-NODES.
002960     IF NO-NODES GREATER THAN 999,
002970             DISPLAY 'NUMBER OF INTERSECT NODES ON TO SIDE',
002980             ' GREATER THAN 999.',
002990             STOP RUN.
003000     MOVE TEST-NODE TO I-NODES (NO-NODES).
003010     MOVE PASS-N TO PASS-NO.
003020 GEN-IDSM.
003030     PERFORM GEN-IDSM-LOOP VARYING COUNT FROM 1 BY 1 UNTIL COUNT
003040             GREATER THAN NO-REC.
003050     GO TO DONE-TEST-2.
003060 GEN-IDSM-LOOP.
003070     WRITE IDSM-REC FROM WS (COUNT).
003080 DONE-TEST-2.
003090     IF OVERFLOW-COUNT NOT EQUAL ZERO, GO TO OVERFLOW-READ-LOOP-2.
003100     IF DONE-FLAG EQUAL FLAG-ON, GO TO LOAD-I-NODES-EXIT.
003110     MOVE ZERO TO REC-NO.
003120     GO TO PRIME-TEST-NODE-2.
003130 LOAD-I-NODES-EXIT.
003140     EXIT.
003150 PATH-REPORT-SORT SECTION.
003160     OPEN INPUT IDSM.
003170     OPEN OUTPUT NRDM.
003180     SORT SORTF ON ASCENDING KEY SF-19T30,
003190         INPUT PROCEDURE READ-RELEASE-IDSM,
003200         OUTPUT PROCEDURE F-NODE-EXTRACT THRU GEN-OUTPUT-FILES.
003210     CLOSE IDSM, NRDM.
003220     GO TO NODE-REPORT-SORT.
003230 READ-RELEASE-IDSM SECTION.
003240     DISPLAY 'ENTER PATH-REPORT-SORT INPUT PROCEDURE'.
003250 READ-RELEASE-LOOP.
003260     READ IDSM, AT END GO TO READ-RELEASE-EXIT.
003270     MOVE IDSM-REC TO SF.
003280     RELEASE SF.
003290     GO TO READ-RELEASE-LOOP.
003300 READ-RELEASE-EXIT.
003310     EXIT.
003320 F-NODE-EXTRACT SECTION.
003330     DISPLAY 'ENTER PATH-REPORT-SORT OUTPUT PROCEDURE'.
003340     MOVE SPACES TO TEST-NODE.
003350     MOVE FLAG-OFF TO DONE-FLAG.
003360     MOVE ZEROS TO REC-NO, OVERFLOW-COUNT.
003370     MOVE 1 TO IINDEX.
003380     PERFORM PRIME-TREE-TABLE VARYING COUNT FROM 1 BY 1 UNTIL
003390             COUNT GREATER THAN 999.
003400     GO TO RETURN-P-R-SORT-LOOP.
003410 PRIME-TREE-TABLE.
003420     MOVE COUNT TO TREE-TABLE (COUNT).
003430 RETURN-P-R-SORT-LOOP.
003440     RETURN SORTF, AT END MOVE FLAG-ON TO DONE-FLAG,
003450                   GO TO OVERFLOW-TEST-3.
003460     IF SF-180 EQUAL 'T',
003470             MOVE SF TO WS (1),
003480             MOVE TREE (1) TO NRD-1T6,
003490             MOVE PATH (1) TO NRD-7T12,
003500             MOVE SWITCH (1) TO NRD-13,
003510             MOVE BOX-REF-DES (1) TO NRD-14T28,
003520             MOVE BRANCH (1) TO NRD-29T60,
003530             MOVE SPACES TO NRD-29T30, NRD-45T46,
003540             MOVE F-NODE (1) TO NRD-61T66,
003550             MOVE FLAG (1) TO NRD-67,
003560             MOVE BID-RMK (1) TO NRD-68T104,
003570             WRITE NRDM-REC,
003580             GO TO RETURN-P-R-SORT-LOOP.
003590     IF TEST-NODE NOT EQUAL SPACES, GO TO NEW-NODE-TEST-3.
003600 PRIME-TEST-NODE-3.
003610     ALTER I-O-MODE TO PROCEED TO WRITE-DATA.
003620     IF AOFS-STATUS EQUAL OPENED,
003630             CLOSE AOFS,
003640             MOVE CLOSED TO AOFS-STATUS.
003650     MOVE SF-19T24 TO TEST-NODE.
003660     GO TO STORE-REC-TEST-3.
003670 NEW-NODE-TEST-3.
003680     IF SF-19T24 NOT EQUAL TEST-NODE, GO TO OVERFLOW-TEST-3.
003690 STORE-REC-TEST-3.
003700     ADD 1 TO REC-NO.
003710     IF REC-NO NOT GREATER THAN MAX-REC, GO TO STORE-REC-3.
003720     MOVE MAX-REC TO NO-REC.
003730     PERFORM ARRAY-OVERFLOW-RECOVERY.
003740     ADD 1 TO OVERFLOW-COUNT.
003750     MOVE 1 TO REC-NO.
003760 STORE-REC-3.
003770     MOVE SF TO WS (REC-NO).
003780     GO TO RETURN-P-R-SORT-LOOP.
003790 OVERFLOW-TEST-3.
003800     IF OVERFLOW-COUNT EQUAL ZERO, GO TO F-NODE-EXTRACT-EXIT.
003810     MOVE REC-NO TO NO-REC.
003820     PERFORM ARRAY-OVERFLOW-RECOVERY.
003830     ADD 1 TO OVERFLOW-COUNT.
003840 F-NODE-EXTRACT-EXIT.
003850     EXIT.
003860 REPORTABLE-NODE-TEST SECTION.
003870     ALTER I-O-MODE TO PROCEED TO READ-DATA.
003880     IF AOFS-STATUS EQUAL OPENED,
003890             CLOSE AOFS,
003900             MOVE CLOSED TO AOFS-STATUS.
003910     MOVE OVERFLOW-COUNT TO SAVE-COUNT.
003920     MOVE PASS-1 TO PASS-NO.
003930     IF OVERFLOW-COUNT EQUAL ZERO,
003940             MOVE REC-NO TO NO-REC,
003950             GO TO SEARCH-I-NODES.
003960 OVERFLOW-READ-LOOP-4.
003970     SUBTRACT 1 FROM OVERFLOW-COUNT.
003980     IF OVERFLOW-COUNT EQUAL ZERO,
003990             MOVE REC-NO TO NO-REC,
004000             PERFORM ARRAY-OVERFLOW-RECOVERY,
004010             MOVE 1 TO POS,
004020             GO TO SECOND-T-NODE-TEST.
004030     MOVE MAX-REC TO NO-REC.
004040     PERFORM ARRAY-OVERFLOW-RECOVERY.
004050     IF PASS-NO NOT EQUAL PASS-1, MOVE 1 TO POS,
004060                                  GO TO SECOND-T-NODE-TEST.
004070     MOVE PASS-N TO PASS-NO.
004080 SEARCH-I-NODES.
004090     IF TEST-NODE EQUAL I-NODES (IINDEX), GO TO STORE-R.
004100     IF TEST-NODE GREATER THAN I-NODES (IINDEX),
004110             ADD 1 TO IINDEX,
004120            IF IINDEX NOT GREATER THAN NO-NODES,
004130                     GO TO SEARCH-I-NODES,
004140                     ELSE SUBTRACT 1 FROM IINDEX.
004150     MOVE T-NODE (1) TO FIRST-NODE.
004160     MOVE 2 TO POS.
004170 SECOND-T-NODE-TEST.
004180     IF POS GREATER THAN NO-REC, GO TO DONE-TEST-4.
004190     IF FLAG (POS) EQUAL 'B' OR 'N' OR 'S', GO TO STORE-R.
004200     IF T-NODE (POS) EQUAL FIRST-NODE, ADD 1 TO POS,
004210                                       GO TO SECOND-T-NODE-TEST.
004220 STORE-R.
004230     MOVE 'R' TO CHAR.
004240     GO TO RELOAD-OVERFLOW-COUNT.
004250 DONE-TEST-4.
004260     IF OVERFLOW-COUNT NOT EQUAL ZERO, GO TO OVERFLOW-READ-LOOP-4.
004270     MOVE SPACE TO CHAR.
004280 RELOAD-OVERFLOW-COUNT.
004290     MOVE SAVE-COUNT TO OVERFLOW-COUNT.
004300 REPORTABLE-NODE-TEST-EXIT.
004310     EXIT.
004320 GEN-OUTPUT-FILES SECTION.
004330     IF AOFS-STATUS EQUAL OPENED,
004340             CLOSE AOFS,
004350             MOVE CLOSED TO AOFS-STATUS.
004360     IF OVERFLOW-COUNT EQUAL ZERO, GO TO WRITE-LOOP.
004370 OVERFLOW-READ-LOOP-5.
004380     SUBTRACT 1 FROM OVERFLOW-COUNT.
004390     IF OVERFLOW-COUNT EQUAL ZERO, MOVE REC-NO TO NO-REC,
004400                                   ELSE MOVE MAX-REC TO NO-REC.
004410     PERFORM ARRAY-OVERFLOW-RECOVERY.
004420 WRITE-LOOP.
004430     PERFORM WRITE-NRDM-DATA THRU WRITE-NRDM-EXIT VARYING COUNT
004440             FROM 1 BY 1 UNTIL COUNT GREATER THAN NO-REC.
004450     GO TO OVERFLOW-TEST-5.
004460 WRITE-NRDM-DATA.
004470     IF CHAR NOT EQUAL 'R', GO TO WRITE-NRDM-EXIT.
004480     IF BOX-REF-DES (COUNT) EQUAL SPACES,
004490             MOVE BED-RMK (COUNT) TO NRD-68T104,
004500             MOVE AREA-HARNESS (COUNT) TO BOX-REF-DES (COUNT),
004510             ELSE MOVE BID-RMK (COUNT) TO NRD-68T104.
004520     MOVE TREE (COUNT) TO NRD-1T6, TREE-NUM.
004530     MOVE PATH (COUNT) TO NRD-7T12.
004540     MOVE SWITCH (COUNT) TO NRD-13.
004550     MOVE BOX-REF-DES (COUNT) TO NRD-14T28.
004560     MOVE BRANCH (COUNT) TO NRD-29T60.
004570     MOVE SPACES TO NRD-29T30, NRD-45T46.
004580     MOVE F-NODE (COUNT) TO NRD-61T66.
004590     MOVE FLAG (COUNT) TO NRD-67.
004600     WRITE NRDM-REC.
004610     IF COUNT EQUAL 1, MOVE TREE-TABLE (TREE-NO) TO TEST-TREE,
004620                       GO TO WRITE-NRDM-EXIT.
004630     IF TREE-NUM NOT EQUAL TEST-TREE,
004640             MOVE TEST-TREE TO TREE-TABLE (TREE-NO).
004650 WRITE-NRDM-EXIT.
004660     EXIT.
004670 OVERFLOW-TEST-5.
004680     IF OVERFLOW-COUNT NOT EQUAL ZERO, GO TO OVERFLOW-READ-LOOP-5.
004690     IF AOFS-STATUS EQUAL OPENED,
004700             CLOSE AOFS,
004710             MOVE CLOSED TO AOFS-STATUS.
004720     IF DONE-FLAG EQUAL FLAG-ON, GO TO GEN-OUTPUT-FILES-EXIT.
004730     MOVE ZERO TO REC-NO.
004740     GO TO PRIME-TEST-NODE-3.
004750 GEN-OUTPUT-FILES-EXIT.
004760     EXIT.
004770 NODE-REPORT-SORT SECTION.
004780     OPEN INPUT NRDM.
004790     SORT SORTF ON ASCENDING KEY SF-1T6, SF-14T60, SF-7T12,
004800         INPUT PROCEDURE NODAL-SET-CONST,
004810         OUTPUT PROCEDURE GEN-NRDM.
004820     CLOSE NRDM.
004830     STOP RUN.
004840 NODAL-SET-CONST SECTION.
004850     DISPLAY 'ENTER NODE-REPORT-SORT INPUT PROCEDURE'.
004860 READ-NRDM-LOOP.
004870     READ NRDM, AT END, GO TO NODAL-SET-CONST-EXIT.
004880     MOVE NRD-1T6 TO TREE-NUM.
004890     MOVE TREE-TABLE (TREE-NO) TO NRD-1T6.
004900     MOVE NRDM-REC TO SF-1T104.
004910     RELEASE SF.
004920     GO TO READ-NRDM-LOOP.
004930 NODAL-SET-CONST-EXIT.
004940     EXIT.
004950 GEN-NRDM SECTION.
004960     DISPLAY 'ENTER NODE-REPORT-SORT OUTPUT PROCEDURE'.
004970     CLOSE NRDM, OPEN OUTPUT NRDM.
004980 RETURN-N-R-SORT-LOOP.
004990     RETURN SORTF, AT END GO TO GEN-NRDM-EXIT.
005000     MOVE SF-1T104 TO NRDM-REC.
005010     WRITE NRDM-REC.
005020     GO TO RETURN-N-R-SORT-LOOP.
005030 GEN-NRDM-EXIT.
005040     EXIT.
005050 ARRAY-OVERFLOW-RECOVERY SECTION.
005060     DISPLAY 'ENTER ARRAY-OVERFLOW-RECOVERY. NO-REC= ' NO-REC.
005070 I-O-MODE.
005080     GO TO.
005090 WRITE-DATA.
005100     IF AOFS-STATUS EQUAL CLOSED,
005110             OPEN OUTPUT AOFS,
005120             MOVE OPENED TO AOFS-STATUS.
005130     PERFORM OVERFLOW-WRITE VARYING COUNT FROM 1 BY 1 UNTIL COUNT
005140             GREATER THAN NO-REC.
005150     GO TO ARRAY-OVERFLOW-RECOVERY-EXIT.
005160 OVERFLOW-WRITE.
005170     WRITE AOFS-REC FROM WS (COUNT).
005180 READ-DATA.
005190     IF AOFS-STATUS EQUAL CLOSED,
005200             OPEN INPUT AOFS,
005210             MOVE OPENED TO AOFS-STATUS.
005220     PERFORM OVERFLOW-READ VARYING COUNT FROM 1 BY 1 UNTIL COUNT
005230             GREATER THAN NO-REC.
005240     GO TO ARRAY-OVERFLOW-RECOVERY-EXIT.
005250 OVERFLOW-READ.
005260     READ AOFS, AT END GOBACK.
005270     MOVE AOFS-REC TO WS (COUNT).
005280 ARRAY-OVERFLOW-RECOVERY-EXIT.
005290     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.     'IASNRP'.
000030 AUTHOR.         LARRY J ROGOVEIN.
000040 INSTALLATION.   BOEING HOUSTON.
000050 DATE-WRITTEN.   FEBRUARY 11, 1969.
000060 DATE-COMPILED. JUN  6, 1969
000070 REMARKS.        THIS IS THE ASP INTERSECT AND SPECIAL NODE MATRIX
000080                 REPORT PROGRAM.  THIS PROGRAM
000090                 PROCESSES THE NODE REPORT DATA MASTER BY
000100                  1) IDENTIFYING ALL TERMINAL BRANCHES AND
000110                     PRODUCING A TERMINAL BRANCH DATA FILE,
000120                  2) IDENTIFYING ALL SWITCHED BRANCHES AND
000130                     PRODUCING A SWITCHED BRANCH DATA FILE,
000140                  3) IDENTIFYING ALL SPECIAL NODE BRANCHES AND
000150                     PRODUCING A SPECIAL NODE BRANCH DATA FILE,
000160                  4) PRODUCING AN INTERSECTION AND SPECIAL NODE
000170                     MATRIX REPORT.
000180 ENVIRONMENT DIVISION.
000190 CONFIGURATION SECTION.
000200 SOURCE-COMPUTER.    IBM-360.
000210 OBJECT-COMPUTER.    IBM-360.
000220 INPUT-OUTPUT SECTION.
000230 FILE-CONTROL.
000240     SELECT CARD ASSIGN TO UT-S-CARDF.
000250     SELECT NRDM ASSIGN TO UT-S-NRDMSTR.
000260     SELECT CSTB ASSIGN TO UT-S-GSTERMB.
000270     SELECT CSSB ASSIGN TO UT-S-CSWTCHB.
000280     SELECT CSSN ASSIGN TO UT-S-CSSNODE.
000290     SELECT LIST ASSIGN TO UT-S-LISTF.
000300 DATA DIVISION.
000310 FILE SECTION.
000320 FD  CARD
000330     LABEL RECORD IS OMITTED
000340     RECORDING MODE IS F
000350     RECORD CONTAINS 80 CHARACTERS
000360     DATA RECORD IS CARD-REC.
000370 01  CARD-REC                PICTURE X(80).
000380 FD  NRDM
000390     LABEL RECORD IS STANDARD
000400     RECORDING MODE IS F
000410     BLOCK CONTAINS 11 RECORDS
000420     RECORD CONTAINS 104 CHARACTERS
000430     DATA RECORD IS NRDM-REC.
000440 01  NRDM-REC.
000450   02  SET-NO                PICTURE X(6).
000460   02  PATH                  PICTURE X(6).
000470   02  SWITCH                PICTURE X.
000480   02  BRANCH.
000490     03  NODE                PICTURE X(31).
000500     03  NRD-45T60           PICTURE X(16).
000510   02  NODE-NO               PICTURE X(6).
000520   02  FLAG                  PICTURE X.
000530   02  REMARK                PICTURE X(37).
000540 FD  CSTB
000550     LABEL RECORD IS STANDARD
000560     RECORDING MODE IS F
000570     BLOCK CONTAINS 25 RECORDS
000580     RECORD CONTAINS 96 CHARACTERS
000590     DATA RECORD IS CSTB-REC.
000600 01  CSTB-REC.
000610   02  TB-1T6                PICTURE X(6).
000620   02  TB-7T53               PICTURE X(47).
000630   02  TB-54T59              PICTURE X(6).
000640   02  TB-60T96              PICTURE X(37).
000650 FD  CSSB
000660     LABEL RECORD IS STANDARD
000670     RECORDING MODE IS F
000680     BLOCK CONTAINS 25 RECORDS
000690     RECORD CONTAINS 96 CHARACTERS
000700     DATA RECORD IS CSSB-REC.
000710 01  CSSB-REC.
000720   02  SB-1T6                PICTURE X(6).
000730   02  SB-7T53               PICTURE X(47).
000740   02  SB-54T59              PICTURE X(6).
000750   02  SB-60T96              PICTURE X(37).
000760 FD  CSSN
000770     LABEL RECORD IS STANDARD
000780     RECORDING MODE IS F
000790     BLOCK CONTAINS 25 RECORDS
000800     RECORD CONTAINS 96 CHARACTERS
000810     DATA RECORD IS CSSN-REC.
000820 01  CSSN-REC.
000830   02  SN-1T6                PICTURE X(6).
000840   02  SN-7T53               PICTURE X(47).
000850   02  SN-54T59              PICTURE X(6).
000860   02  SN-60T96              PICTURE X(37).
000870 FD  LIST
000880     LABEL RECORD IS OMITTED
000890     RECORDING MODE IS F
000900     RECORD CONTAINS 132 CHARACTERS
000910     BLOCK CONTAINS 7 RECORDS
000920     DATA RECORD IS LR.
000930 01  LR.
000940   02  LR-1              PICTURE X.
000950   02  LR-2T48.
000960     03  LR-2T32.
000970       04  LR-2T10       PICTURE X(9).
000980       04  LR-11T32.
000990         05  LR-11T14        PICTURE XXXX.
001000         05  LR-15T19        PICTURE X(5).
001010         05  LR-20T32        PICTURE X(13).
001020     03  LR-33T35        PICTURE XXX.
001030     03  LR-36T41.
001040       04  LR-36T38      PICTURE XXX.
001050       04  LR-39         PICTURE X.
001060       04  LR-40T41      PICTURE XX.
001070     03  LR-42           PICTURE X.
001080     03  LR-43T48.
001090       04  LR-43T45      PICTURE XXX.
001100       04  LR-46         PICTURE X.
001110       04  LR-47T48      PICTURE XX.
001120   02  LR-49             PICTURE X.
001130   02  LR-50T55.
001140     03  LR-50T52        PICTURE XXX.
001150     03  LR-53           PICTURE X.
001160     03  LR-54T55        PICTURE XX.
001170   02  LR-56             PICTURE X.
001180   02  LR-57T111-A.
001190     03  LR-57T83.
001200       04  LR-57T76.
001210         05  LR-57T69.
001220           06  LR-57T62.
001230             07  LR-57T59    PICTURE XXX.
001240             07  LR-60       PICTURE X.
001250             07  LR-61T62    PICTURE XX.
001260           06  LR-63         PICTURE X.
001270           06  LR-64T69.
001280             07  LR-64T66    PICTURE XXX.
001290             07  LR-67       PICTURE X.
001300             07  LR-68T69    PICTURE XX.
001310         05  LR-70           PICTURE X.
001320         05  LR-71T76.
001330           06  LR-71T73      PICTURE XXX.
001340           06  LR-74         PICTURE X.
001350           06  LR-75T76      PICTURE XX.
001360       04  LR-77             PICTURE X.
001370       04  LR-78T83.
001380         05  LR-78T80        PICTURE XXX.
001390         05  LR-81           PICTURE X.
001400         05  LR-82T83        PICTURE XX.
001410     03  LR-84               PICTURE X.
001420     03  LR-85T90.
001430       04  LR-85T87          PICTURE XXX.
001440       04  LR-88             PICTURE X.
001450       04  LR-89T90          PICTURE XX.
001460     03  LR-91T97.
001470       04  LR-91             PICTURE X.
001480       04  LR-92T97.
001490         05  LR-92T94        PICTURE XXX.
001500         05  LR-95           PICTURE X.
001510         05  LR-96T97        PICTURE XX.
001520     03  LR-98               PICTURE X.
001530     03  LR-99T111.
001540       04  LR-99T104.
001550         05  LR-99T101       PICTURE XXX.
001560         05  LR-102          PICTURE X.
001570         05  LR-103T104      PICTURE XX.
001580       04  LR-105            PICTURE X.
001590       04  LR-106T111.
001600         05  LR-106T108      PICTURE XXX.
001610         05  LR-109T111.
001620           06  LR-109        PICTURE X.
001630           06  LR-110T111    PICTURE XX.
001640   02  LR-57T111-B REDEFINES LR-57T111-A.
001650     03  LR-57T74            PICTURE X(18).
001660     03  LR-75T111           PICTURE X(37).
001670   02  LR-112            PICTURE X.
001680   02  LR-113T132.
001690     03  LR-113T118.
001700       04  LR-113T115    PICTURE XXX.
001710       04  LR-116        PICTURE X.
001720       04  LR-117T118    PICTURE XX.
001730     03  LR-119          PICTURE X.
001740     03  LR-120T125.
001750       04  LR-120T122    PICTURE XXX.
001760       04  LR-123        PICTURE X.
001770       04  LR-124T125    PICTURE XX.
001780     03  LR-126T132.
001790       04  LR-126        PICTURE X.
001800       04  LR-127T132.
001810         05  LR-127T129  PICTURE XXX.
001820         05  LR-130      PICTURE X.
001830         05  LR-131T132  PICTURE XX.
001840 WORKING-STORAGE SECTION.
001850 77  COL                 PICTURE 999.
001860 77  COLP1               PICTURE 999.
001870 77  COLP2               PICTURE 999.
001880 77  COLP3               PICTURE 999.
001890 77  COLP4               PICTURE 999.
001900 77  COLP5               PICTURE 999.
001910 77  COLP6               PICTURE 999.
001920 77  COLP7               PICTURE 999.
001930 77  COLP8               PICTURE 999.
001940 77  COLP9               PICTURE 999.
001950 77  COLP10              PICTURE 999.
001960 77  COLP11              PICTURE 999.
001970 77  COLP12              PICTURE 999.
001980 77  COLP13              PICTURE 999.
001990 77  CONTINUE-FLAG       PICTURE 9.
002000 77  COUNT               PICTURE 999.
002010 77  DONE-FLAG           PICTURE 9.
002020 77  ELEM                PICTURE X(6).
002030 77  ELEM-FLAG           PICTURE 9.
002040 77  FLAG-OFF            PICTURE 9       VALUE 0.
002050 77  FLAG-ON             PICTURE 9       VALUE 1.
002060 77  MAX-COLS                PICTURE 999     VALUE 487.
002070 77  MAX-ROWS                PICTURE 999     VALUE 250.
002080 77  N-COUNT             PICTURE 999.
002090 77  N-LOC               PICTURE 999.
002100 77  NODAL-SET           PICTURE 999.
002110 77  NUM                 PICTURE 999.
002120 77  PAGE-NO             PICTURE 99.
002130 77  PAGE-NO-START       PICTURE 99.
002140 77  P-COUNT             PICTURE 999.
002150 77  P-LOC               PICTURE 999.
002160 77  POS                 PICTURE 999.
002170 77  ROW                 PICTURE 999.
002180 77  TEST-SET                PICTURE X(6).
002190 01  REPORT-ID-DATA.
002200   02  VEHICLE-ID        PICTURE X(47).
002210   02  DATE              PICTURE X(20).
002220   02  FILLER            PICTURE X(13).
002230 01  WS-1-ARRAY.
002240   02  WS-1                                  OCCURS 500 TIMES.
002250     03  PATHS               PICTURE X(6).
002260     03  SWITCHES            PICTURE X.
002270     03  ARRAY               PICTURE X(6).
002280 01  WS-2-ARRAY.
002290   02  WS-2                                  OCCURS 250 TIMES.
002300     03  NODE-NOS            PICTURE X(6).
002310     03  NODES               PICTURE X(31).
002320 01  MATRIX-ARRAY.
002330   02  MATRIX-LEVEL1                 OCCURS 500 TIMES.
002340     03  MATRIX          PICTURE X   OCCURS 250 TIMES.
002350 PROCEDURE DIVISION.
002360     OPEN INPUT CARD, NRDM.
002370     OPEN OUTPUT LIST, CSTB, CSSB, CSSN.
002380     MOVE SPACES TO TEST-SET.
002390     MOVE FLAG-OFF TO DONE-FLAG, CONTINUE-FLAG.
002400     MOVE ZERO TO PAGE-NO-START.
002410     MOVE 1 TO NODAL-SET.
002420     READ CARD INTO REPORT-ID-DATA, AT END STOP RUN.
002430     CLOSE CARD.
002440 READ-NRDM-LOOP.
002450     READ NRDM, AT END MOVE FLAG-ON TO DONE-FLAG,
002460                       GO TO REPORT-GEN.
002470     IF TEST-SET NOT EQUAL SPACES, GO TO NEW-SET-TEST.
002480 PRIME-TEST-SET.
002490     MOVE SET-NO TO TEST-SET.
002500     MOVE 1 TO P-COUNT, N-COUNT.
002510     PERFORM PRIME-COLUMNS THRU PRIME-EXIT VARYING POS FROM 1 BY 1
002520             UNTIL POS GREATER THAN MAX-COLS.
002530     GO TO TERMINAL-BRANCH-TEST.
002540 PRIME-COLUMNS.
002550     MOVE SPACES TO PATHS (POS), SWITCHES (POS).
002560     PERFORM PRIME-ROWS VARYING COUNT FROM 1 BY 1 UNTIL COUNT
002570             GREATER THAN MAX-ROWS.
002580     GO TO PRIME-EXIT.
002590 PRIME-ROWS.
002600     IF POS EQUAL 1, MOVE SPACES TO NODES (COUNT),
002610                                    NODE-NOS (COUNT).
002620     MOVE '0' TO MATRIX (POS, COUNT).
002630 PRIME-EXIT.
002640     EXIT.
002650 NEW-SET-TEST.
002660     IF SET-NO NOT EQUAL TEST-SET, GO TO REPORT-GEN.
002670 TERMINAL-BRANCH-TEST.
002680     IF FLAG EQUAL 'T', MOVE NODAL-SET TO TB-1T6,
002690                        MOVE BRANCH TO TB-7T53,
002700                        MOVE PATH TO TB-54T59,
002710                        MOVE REMARK TO TB-60T96,
002720                             WRITE CSTB-REC,
002730                             GO TO READ-NRDM-LOOP.
002740     IF FLAG EQUAL 'S', MOVE NODAL-SET TO SB-1T6,
002750                        MOVE BRANCH TO SB-7T53,
002760                        MOVE PATH TO SB-54T59,
002770                        MOVE REMARK TO SB-60T96,
002780                             WRITE CSSB-REC,
002790                             GO TO READ-NRDM-LOOP.
002800 MATRIX-CONST.
002810     MOVE PATH TO ELEM.
002820     MOVE P-COUNT TO COUNT.
002830     ALTER LOAD-ARRAY TO PROCEED TO LOAD-WITH-PATHS.
002840     PERFORM NEW-ELEM-TEST.
002850     MOVE NUM TO P-LOC.
002860     IF ELEM-FLAG EQUAL FLAG-OFF, GO TO FIND-NODE.
002870     IF P-COUNT GREATER THAN MAX-COLS,
002880             MOVE FLAG-ON TO CONTINUE-FLAG,
002890             GO TO REPORT-GEN.
002900     MOVE ELEM TO PATHS (P-COUNT).
002910     MOVE SWITCH TO SWITCHES (P-COUNT).
002920     ADD 1 TO P-COUNT.
002930 FIND-NODE.
002940     MOVE NODE-NO TO ELEM.
002950     MOVE N-COUNT TO COUNT.
002960     ALTER LOAD-ARRAY TO PROCEED TO LOAD-WITH-NODES.
002970     PERFORM NEW-ELEM-TEST.
002980     MOVE NUM TO N-LOC.
002990     IF ELEM-FLAG EQUAL FLAG-OFF, GO TO LOAD-MATRIX.
003000     IF N-COUNT GREATER THAN MAX-ROWS,
003010             MOVE FLAG-ON TO CONTINUE-FLAG,
003020             GO TO REPORT-GEN.
003030     MOVE ELEM TO NODE-NOS (N-COUNT).
003040     MOVE NODE TO NODES (N-COUNT).
003050     ADD 1 TO N-COUNT.
003060 LOAD-MATRIX.
003070     MOVE '1' TO MATRIX (P-LOC, N-LOC).
003080     IF FLAG EQUAL 'N', GO TO STORE-CSSN.
003090     IF FLAG NOT EQUAL 'B', GO TO READ-NRDM-LOOP.
003100     MOVE NODAL-SET TO SB-1T6.
003110     MOVE BRANCH TO SB-7T53.
003120     MOVE PATH TO SB-54T59.
003130     MOVE REMARK TO SB-60T96.
003140     WRITE CSSB-REC.
003150 STORE-CSSN.
003160     MOVE NODAL-SET TO SN-1T6.
003170     MOVE BRANCH TO SN-7T53.
003180     MOVE PATH TO SN-54T59.
003190     MOVE REMARK TO SN-60T96.
003200     WRITE CSSN-REC.
003210     GO TO READ-NRDM-LOOP.
003220 NEW-ELEM-TEST SECTION.
003230     MOVE FLAG-OFF TO ELEM-FLAG.
003240     IF COUNT EQUAL 1, MOVE 1 TO NUM,
003250                       GO TO SET-FLAG.
003260 LOAD-ARRAY.
003270     GO TO.
003280 LOAD-WITH-PATHS.
003290     PERFORM LOAD-PATHS VARYING NUM FROM 1 BY 1 UNTIL NUM NOT LESS
003300         THAN COUNT.
003310     GO TO FIND-ELEM.
003320 LOAD-PATHS.
003330     MOVE PATHS (NUM) TO ARRAY (NUM).
003340 LOAD-WITH-NODES.
003350     PERFORM LOAD-NODES VARYING NUM FROM 1 BY 1 UNTIL NUM NOT LESS
003360             THAN COUNT.
003370     GO TO FIND-ELEM.
003380 LOAD-NODES.
003390     MOVE NODE-NOS (NUM) TO ARRAY (NUM).
003400 FIND-ELEM.
003410     MOVE 1 TO NUM.
003420 ELEM-SEARCH-LOOP.
003430     IF ELEM EQUAL ARRAY (NUM), GO TO NEW-ELEM-TEST-EXIT.
003440     ADD 1 TO NUM.
003450     IF NUM LESS THAN COUNT, GO TO ELEM-SEARCH-LOOP.
003460 SET-FLAG.
003470     MOVE FLAG-ON TO ELEM-FLAG.
003480 NEW-ELEM-TEST-EXIT.
003490     EXIT.
003500 REPORT-GEN SECTION.
003510     PERFORM PURGE-ROWS THRU PURGE-EXIT VARYING POS FROM 1 BY 1
003520         UNTIL POS NOT LESS THAN N-COUNT.
003530     GO TO INITIAL-4D.
003540 PURGE-ROWS.
003550     MOVE P-COUNT TO COUNT.
003560     PERFORM PURGE-COLS 13 TIMES.
003570 PURGE-COLS.
003580     MOVE SPACE TO MATRIX (COUNT, POS).
003590     ADD 1 TO COUNT.
003600 PURGE-EXIT.
003610     EXIT.
003620 INITIAL-4D.
003630     MOVE 1 TO ROW, COL.
003640     MOVE PAGE-NO-START TO PAGE-NO.
003650 PAGE-HEADING.
003660     MOVE SPACES TO LR.
003670     MOVE 'A S P  NODE  REPORT' TO LR-57T76.
003680     WRITE LR AFTER POSITIONING 0.
003690     ADD 1 TO PAGE-NO.
003700     MOVE SPACES TO LR.
003710     MOVE 'NODAL SET    ' TO LR-99T111.
003720     MOVE NODAL-SET TO LR-109T111.
003730     MOVE 'PAGE   ' TO LR-126T132.
003740     MOVE PAGE-NO TO LR-131T132.
003750     WRITE LR AFTER POSITIONING 2.
003760     MOVE SPACES TO LR.
003770     MOVE 'NODES' TO LR-15T19.
003780     MOVE 'PATHS' TO LR-78T83.
003790     WRITE LR AFTER POSITIONING 2.
003800     COMPUTE COLP1 = COL + 1.
003810     COMPUTE COLP2 = COL + 2.
003820     COMPUTE COLP3 = COL + 3.
003830     COMPUTE COLP4 = COL + 4.
003840     COMPUTE COLP5 = COL + 5.
003850     COMPUTE COLP6 = COL + 6.
003860     COMPUTE COLP7 = COL + 7.
003870     COMPUTE COLP8 = COL + 8.
003880     COMPUTE COLP9 = COL + 9.
003890     COMPUTE COLP10 = COL + 10.
003900     COMPUTE COLP11 = COL + 11.
003910     COMPUTE COLP12 = COL + 12.
003920     COMPUTE COLP13 = COL + 13.
003930     MOVE SPACES TO LR.
003940     MOVE 'BOX  REF  DES    ITEM  BAY PIN ' TO LR-2T32.
003950     MOVE PATHS (COL) TO LR-36T41.
003960     MOVE PATHS (COLP1) TO LR-43T48.
003970     MOVE PATHS (COLP2) TO LR-50T55.
003980     MOVE PATHS (COLP3) TO LR-57T62.
003990     MOVE PATHS (COLP4) TO LR-64T69.
004000     MOVE PATHS (COLP5) TO LR-71T76.
004010     MOVE PATHS (COLP6) TO LR-78T83.
004020     MOVE PATHS (COLP7) TO LR-85T90.
004030     MOVE PATHS (COLP8) TO LR-92T97.
004040     MOVE PATHS (COLP9) TO LR-99T104.
004050     MOVE PATHS (COLP10) TO LR-106T111.
004060     MOVE PATHS (COLP11) TO LR-113T118.
004070     MOVE PATHS (COLP12) TO LR-120T125.
004080     MOVE PATHS (COLP13) TO LR-127T132.
004090     WRITE LR AFTER POSITIONING 1.
004100     MOVE SPACES TO LR.
004110     MOVE SWITCHES (COL) TO LR-39.
004120     MOVE SWITCHES (COLP1) TO LR-46.
004130     MOVE SWITCHES (COLP2) TO LR-53.
004140     MOVE SWITCHES (COLP3) TO LR-60.
004150     MOVE SWITCHES (COLP4) TO LR-67.
004160     MOVE SWITCHES (COLP5) TO LR-74.
004170     MOVE SWITCHES (COLP6) TO LR-81.
004180     MOVE SWITCHES (COLP7) TO LR-88.
004190     MOVE SWITCHES (COLP8) TO LR-95.
004200     MOVE SWITCHES (COLP9) TO LR-102.
004210     MOVE SWITCHES (COLP10) TO LR-109.
004220     MOVE SWITCHES (COLP11) TO LR-116.
004230     MOVE SWITCHES (COLP12) TO LR-123.
004240     MOVE SWITCHES (COLP13) TO LR-130.
004250     WRITE LR AFTER POSITIONING 1.
004260     MOVE 1 TO NUM.
004270 DATA-LOOP.
004280     MOVE SPACES TO LR.
004290     MOVE NODES (ROW) TO LR-2T32.
004300     MOVE MATRIX (COL, ROW) TO LR-39.
004310     MOVE MATRIX (COLP1, ROW) TO LR-46.
004320     MOVE MATRIX (COLP2, ROW) TO LR-53.
004330     MOVE MATRIX (COLP3, ROW) TO LR-60.
004340     MOVE MATRIX (COLP4, ROW) TO LR-67.
004350     MOVE MATRIX (COLP5, ROW) TO LR-74.
004360     MOVE MATRIX (COLP6, ROW) TO LR-81.
004370     MOVE MATRIX (COLP7, ROW) TO LR-88.
004380     MOVE MATRIX (COLP8, ROW) TO LR-95.
004390     MOVE MATRIX (COLP9, ROW) TO LR-102.
004400     MOVE MATRIX (COLP10, ROW) TO LR-109.
004410     MOVE MATRIX (COLP11, ROW) TO LR-116.
004420     MOVE MATRIX (COLP12, ROW) TO LR-123.
004430     MOVE MATRIX (COLP13, ROW) TO LR-130.
004440     WRITE LR AFTER POSITIONING 1.
004450     ADD 1 TO ROW.
004460     IF ROW NOT LESS THAN N-COUNT, GO TO MORE-PATHS-TEST.
004470     ADD 1 TO NUM.
004480     IF NUM GREATER THAN 45, GO TO PAGE-HEADING.
004490     GO TO DATA-LOOP.
004500 MORE-PATHS-TEST.
004510     IF COLP13 LESS THAN P-COUNT, ADD 14 TO COL,
004520                                  MOVE 1 TO ROW,
004530                                  GO TO PAGE-HEADING.
004540     IF CONTINUE-FLAG EQUAL FLAG-OFF, GO TO PAGE-FOOTING.
004550     MOVE FLAG-OFF TO CONTINUE-FLAG.
004560     SUBTRACT 1 FROM NODAL-SET.
004570     MOVE PAGE-NO TO PAGE-NO-START.
004580     GO TO DONE-TEST.
004590 PAGE-FOOTING.
004600     MOVE SPACES TO LR.
004610     MOVE VEHICLE-ID TO LR-2T48.
004620     MOVE 'AUTOMATED   SNEAK   PROGRAM' TO LR-57T83.
004630     MOVE DATE TO LR-113T132.
004640     WRITE LR AFTER POSITIONING 2.
004650     MOVE SPACES TO LR.
004660     MOVE 'ANALYST- ' TO LR-2T10.
004670     MOVE 'DATE- ' TO LR-36T41.
004680     MOVE 'MANHOURS-    ' TO LR-57T69.
004690     WRITE LR AFTER POSITIONING 2.
004700     MOVE SPACES TO LR.
004710     MOVE 'SNEAK POSSIBLE    (YES)    (NO)' TO LR-2T32.
004720     WRITE LR AFTER POSITIONING 2.
004730     MOVE SPACES TO LR.
004740     MOVE 'COMMENTS-' TO LR-2T10.
004750     WRITE LR AFTER POSITIONING 2.
004760     MOVE ZEROS TO PAGE-NO-START.
004770 DONE-TEST.
004780     ADD 1 TO NODAL-SET.
004790     IF DONE-FLAG NOT EQUAL FLAG-ON, GO TO PRIME-TEST-SET.
004800     CLOSE NRDM, CSTB, CSSB, CSSN.
004810 CLOSING-COMMENTS.
004820     MOVE SPACES TO LR.
004830     MOVE 'PROCESSING COMPLETE NORMAL EXIT' TO LR-2T32.
004840     WRITE LR AFTER POSITIONING 0.
004850     CLOSE LIST.
004860     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.     CONSUM.
000030 AUTHOR.         LARRY J ROGOVEIN.
000040 INSTALLATION.   BOEING HOUSTON.
000050 DATE-WRITTEN.   MAY 14, 1969.
000060 DATE-COMPILED.  JUNE 19, 1969.
000070 REMARKS.        THIS IS THE ASP CONTROL SUMMARY REPORT PROGRAM.
000080                 THIS PROGRAM PROCESSES THE FOLLOWING FILES.
000090                  1) THE TERMINAL BRANCH DATA FILE,
000100                  2) THE SWITCHED BRANCH DATA FILE,
000110                  3) THE SPECIAL NODE BRANCH DATA-FILE.
000120                 THE FIRST TWO FILES ARE REPORTED BY NODAL SET,
000130                 AND THE LAST FILE IS REPORTED IN ALPHANUMERIC
000140                 ORDER BY CONNECTION DESCRIPTION.
000150 ENVIRONMENT DIVISION.
000160 CONFIGURATION SECTION.
000170 SOURCE-COMPUTER.    IBM-360.
000180 OBJECT-COMPUTER.    IBM-360.
000190 INPUT-OUTPUT SECTION.
000200 FILE-CONTROL.
000210     SELECT CSTB ASSIGN TO UT-S-CSTERMB.
000220     SELECT CSSB ASSIGN TO UT-S-CSWTCHB.
000230     SELECT CSSN ASSIGN TO UT-S-CSSNODE.
000240     SELECT LIST ASSIGN TO UT-S-LISTF.
000250 DATA DIVISION.
000260 FILE SECTION.
000270 FD  CSTB
000280     LABEL RECORD IS STANDARD
000290     RECORDING MODE IS F
000300     BLOCK CONTAINS 25 RECORDS
000310     RECORD CONTAINS 96 CHARACTERS
000320     DATA RECORD IS CSTB-REC.
000330 01  CSTB-REC.
000340   02  TB-1T6                PICTURE X(6).
000350   02  TB-7T53               PICTURE X(47).
000360   02  TB-54T59              PICTURE X(6).
000370   02  TB-60T96              PICTURE X(37).
000380 FD  CSSB
000390     LABEL RECORD IS STANDARD
000400     RECORDING MODE IS F
000410     BLOCK CONTAINS 25 RECORDS
000420     RECORD  CONTAINS   96   CHARACTERS
000430     DATA RECORD IS CSSB-REC.
000440 01  CSSB-REC.
000450   02  SB-1T6                PICTURE X(6).
000460   02  SB-7T53               PICTURE X(47).
000470   02  SB-54T59              PICTURE X(6).
000480   02  SB-60T96              PICTURE X(37).
000490 FD  CSSN
000500     LABEL RECORD IS STANDARD
000510     RECORDING MODE IS F
000520     BLOCK CONTAINS 25 RECORDS
000530     RECORD CONTAINS 96 CHARACTERS
000540     DATA RECORD IS CSSN-REC.
000550 01  CSSN-REC.
000560   02  SN-1T6                PICTURE X(6).
000570   02  SN-7T53               PICTURE X(47).
000580   02  SN-54T59              PICTURE X(6).
000590   02  SN-60T96              PICTURE X(37).
000600 FD  LIST
000610     LABEL RECORD IS OMITTED
000620     RECORDING MODE IS F
000630     RECORD CONTAINS 132 CHARACTERS
000640     BLOCK CONTAINS 7 RECORDS
000650     DATA RECORD IS LR.
000660 01  LR SYNC.
000670   02  LR-1              PICTURE X.
000680   02  LR-2T48.
000690     03  LR-2T32.
000700       04  LR-2T10       PICTURE X(9).
000710       04  LR-11T32.
000720         05  LR-11T14        PICTURE XXXX.
000730         05  LR-15T19        PICTURE X(5).
000740         05  LR-20T32        PICTURE X(13).
000750     03  LR-33T35        PICTURE XXX.
000760     03  LR-36T41.
000770       04  LR-36T38      PICTURE XXX.
000780       04  LR-39         PICTURE X.
000790       04  LR-40T41      PICTURE XX.
000800     03  LR-42           PICTURE X.
000810     03  LR-43T48.
000820       04  LR-43T45      PICTURE XXX.
000830       04  LR-46         PICTURE X.
000840       04  LR-47T48      PICTURE XX.
000850   02  LR-49             PICTURE X.
000860   02  LR-50T55.
000870     03  LR-50T52        PICTURE XXX.
000880     03  LR-53           PICTURE X.
000890     03  LR-54T55        PICTURE XX.
000900   02  LR-56             PICTURE X.
000910   02  LR-57T111-A.
000920     03  LR-57T83.
000930       04  LR-57T76.
000940         05  LR-57T69.
000950           06  LR-57T62.
000960             07  LR-57T59    PICTURE XXX.
000970             07  LR-60       PICTURE X.
000980             07  LR-61T62    PICTURE XX.
000990           06  LR-63         PICTURE X.
001000           06  LR-64T69.
001010             07  LR-64T66    PICTURE XXX.
001020             07  LR-67       PICTURE X.
001030             07  LR-68T69    PICTURE XX.
001040         05  LR-70           PICTURE X.
001050         05  LR-71T76.
001060           06  LR-71T73      PICTURE XXX.
001070           06  LR-74         PICTURE X.
001080           06  LR-75T76      PICTURE XX.
001090       04  LR-77             PICTURE X.
001100       04  LR-78T83.
001110         05  LR-78T80        PICTURE XXX.
001120         05  LR-81           PICTURE X.
001130         05  LR-82T83        PICTURE XX.
001140     03  LR-84               PICTURE X.
001150     03  LR-85T90.
001160       04  LR-85T87          PICTURE XXX.
001170       04  LR-88             PICTURE X.
001180       04  LR-89T90          PICTURE XX.
001190     03  LR-91T97.
001200       04  LR-91             PICTURE X.
001210       04  LR-92T97.
001220         05  LR-92T94        PICTURE XXX.
001230         05  LR-95           PICTURE X.
001240         05  LR-96T97        PICTURE XX.
001250     03  LR-98               PICTURE X.
001260     03  LR-99T111.
001270       04  LR-99T104.
001280         05  LR-99T101       PICTURE XXX.
001290         05  LR-102          PICTURE X.
001300         05  LR-103T104      PICTURE XX.
001310       04  LR-105            PICTURE X.
001320       04  LR-106T111.
001330         05  LR-106T108      PICTURE XXX.
001340         05  LR-109T111.
001350           06  LR-109        PICTURE X.
001360           06  LR-110T111    PICTURE XX.
001370   02  LR-57T111-B REDEFINES LR-57T111-A.
001380     03  LR-57T74            PICTURE X(18).
001390     03  LR-75T111           PICTURE X(37).
001400   02  LR-112            PICTURE X.
001410   02  LR-113T132.
001420     03  LR-113T118.
001430       04  LR-113T115    PICTURE XXX.
001440       04  LR-116        PICTURE X.
001450       04  LR-117T118    PICTURE XX.
001460     03  LR-119          PICTURE X.
001470     03  LR-120T125.
001480       04  LR-120T122    PICTURE XXX.
001490       04  LR-123        PICTURE X.
001500       04  LR-124T125    PICTURE XX.
001510     03  LR-126T132.
001520       04  LR-126        PICTURE X.
001530       04  LR-127T132.
001540         05  LR-127T129  PICTURE XXX.
001550         05  LR-130      PICTURE X.
001560         05  LR-131T132  PICTURE XX.
001570 WORKING-STORAGE SECTION.
001580 77  NUM                 PICTURE 999.
001590 77  PAGE-NO             PICTURE 99.
001600 77  TEST-BRANCH             PICTURE X(47).
001610 77  TEST-SET                PICTURE X(6).
001620 PROCEDURE DIVISION.
001630     OPEN OUTPUT LIST.
001640 TB-CONTROL-SUMMARY SECTION.
001650     OPEN INPUT CSTB.
001660     MOVE SPACES TO TEST-SET.
001670 READ-CSTB-LOOP.
001680     READ CSTB, AT END GO TO TB-CONTROL-SUMMARY-EXIT.
001690     IF TEST-SET EQUAL SPACES, GO TO TB-PRIME.
001700     IF TB-1T6 EQUAL TEST-SET, GO TO TB-NEW-PAGE-TEST.
001710 TB-PRIME.
001720     MOVE ZERO TO PAGE-NO.
001730     MOVE TB-1T6 TO TEST-SET.
001740     GO TO TB-PAGE-HEADING.
001750 TB-NEW-PAGE-TEST.
001760     IF NUM NOT GREATER THAN 55, GO TO TB-WRITE-LOOP.
001770 TB-PAGE-HEADING.
001780     MOVE SPACES TO LR.
001790     MOVE '  A S P  CONTROL  SUMMARY  ' TO LR-57T83.
001800     WRITE LR AFTER POSITIONING 0.
001810     ADD 1 TO PAGE-NO.
001820     MOVE SPACES TO LR.
001830     MOVE 'NODAL SET    ' TO LR-99T111.
001840     MOVE TB-1T6 TO LR-109T111.
001850     MOVE 'PAGE   ' TO LR-126T132.
001860     MOVE PAGE-NO TO LR-131T132.
001870     WRITE LR AFTER POSITIONING 2.
001880     MOVE SPACES TO LR.
001890     MOVE '   TERMINAL  BRANCH   ' TO LR-11T32.
001900     MOVE ' PATH ' TO LR-57T62.
001910     MOVE 'REMARKS' TO LR-91T97.
001920     WRITE LR AFTER POSITIONING 2.
001930     MOVE 1 TO NUM.
001940 TB-WRITE-LOOP.
001950     MOVE SPACES TO LR.
001960     MOVE TB-54T59 TO LR-57T62.
001970     IF NUM EQUAL 1, GO TO TB-LOAD.
001980     IF TB-7T53 EQUAL TEST-BRANCH, GO TO TB-WRITE.
001990 TB-LOAD.
002000     MOVE TB-7T53 TO TEST-BRANCH, LR-2T48.
002010     MOVE TB-60T96 TO LR-75T111.
002020 TB-WRITE.
002030     WRITE LR AFTER POSITIONING 1.
002040     ADD 1 TO NUM.
002050     GO TO READ-CSTB-LOOP.
002060 TB-CONTROL-SUMMARY-EXIT.
002070     EXIT.
002080 SB-CONTROL-SUMMARY SECTION.
002090     CLOSE CSTB.
002100     OPEN INPUT CSSB.
002110     MOVE SPACES TO TEST-SET.
002120 READ-CSSB-LOOP.
002130     READ CSSB, AT END GO TO SB-CONTROL-SUMMARY-EXIT.
002140     IF TEST-SET EQUAL SPACES, GO TO SB-PRIME.
002150     IF SB-1T6 EQUAL TEST-SET, GO TO SB-NEW-PAGE-TEST.
002160 SB-PRIME.
002170     MOVE ZERO TO PAGE-NO.
002180     MOVE SB-1T6 TO TEST-SET.
002190     GO TO SB-PAGE-HEADING.
002200 SB-NEW-PAGE-TEST.
002210     IF NUM NOT GREATER THAN 55, GO TO SB-WRITE-LOOP.
002220 SB-PAGE-HEADING.
002230     MOVE SPACES TO LR.
002240     MOVE '  A S P  CONTROL  SUMMARY  ' TO LR-57T83.
002250     WRITE LR AFTER POSITIONING 0.
002260     ADD 1 TO PAGE-NO.
002270     MOVE SPACES TO LR.
002280     MOVE 'NODAL SET    ' TO LR-99T111.
002290     MOVE SB-1T6 TO LR-109T111.
002300     MOVE 'PAGE   ' TO LR-126T132.
002310     MOVE PAGE-NO TO LR-131T132.
002320     WRITE LR AFTER POSITIONING 2
002330     MOVE SPACES TO LR.
002340     MOVE '   SWITCHED  BRANCH   ' TO LR-11T32.
002350     MOVE ' PATH ' TO LR-57T62.
002360     MOVE 'REMARKS' TO LR-91T97.
002370     WRITE LR AFTER POSITIONING 2
002380     MOVE 1 TO NUM.
002390 SB-WRITE-LOOP.
002400     MOVE SPACES TO LR.
002410     MOVE SB-54T59 TO LR-57T62.
002420     IF NUM EQUAL 1, GO TO SB-LOAD.
002430     IF SB-7T53 EQUAL TEST-BRANCH, GO TO SB-WRITE.
002440 SB-LOAD.
002450     MOVE SB-7T53 TO TEST-BRANCH, LR-2T48.
002460     MOVE SB-60T96 TO LR-75T111.
002470 SB-WRITE.
002480     WRITE LR AFTER POSITIONING 1.
002490     ADD 1 TO NUM.
002500     GO TO READ-CSSB-LOOP.
002510 SB-CONTROL-SUMMARY-EXIT.
002520     EXIT.
002530 SN-CONTROL-SUMMARY-GEN SECTION.
002540     CLOSE CSSB.
002550     DISPLAY 'ENTER SN CONTROL SUMMARY'.
002560     OPEN INPUT CSSN.
002570     MOVE ZERO TO PAGE-NO.
002580     MOVE 56 TO NUM.
002590 READ-CSSN-LOOP.
002600     READ CSSN, AT END GO TO SN-CONTROL-SUMMARY-GEN-EXIT.
002610     IF NUM NOT GREATER THAN 55, GO TO SN-WRITE-LOOP.
002620 SN-PAGE-HEADING.
002630     MOVE SPACES TO LR.
002640     MOVE '  A S P  CONTROL  SUMMARY  ' TO LR-57T83.
002650     WRITE LR AFTER POSITIONING 0.
002660     ADD 1 TO PAGE-NO.
002670     MOVE SPACES TO LR.
002680     MOVE 'PAGE   ' TO LR-126T132.
002690     MOVE PAGE-NO TO LR-131T132.
002700     WRITE LR AFTER POSITIONING 2.
002710     MOVE SPACES TO LR.
002720     MOVE 'SPECIAL NODE BRANCH   ' TO LR-11T32.
002730     MOVE ' PATH ' TO LR-57T62.
002740     MOVE 'REMARKS' TO LR-91T97.
002750     MOVE ' N' TO LR-117T118.
002760     MOVE 'O' TO LR-119.
002770     MOVE 'DAL SE' TO LR-120T125.
002780     MOVE 'T' TO LR-126.
002790     WRITE LR AFTER POSITIONING 2.
002800     MOVE 1 TO NUM.
002810 SN-WRITE-LOOP.
002820     MOVE SPACES TO LR.
002830     MOVE SN-7T53 TO LR-2T48.
002840     MOVE SN-54T59 TO LR-57T62.
002850     MOVE SN-60T96 TO LR-75T111.
002860     MOVE SN-1T6 TO LR-120T125.
002870     WRITE LR AFTER POSITIONING 1.
002880     ADD 1 TO NUM.
002890     GO TO READ-CSSN-LOOP.
002900 SN-CONTROL-SUMMARY-GEN-EXIT.
002910     EXIT.
002920 CLOSING-COMMENTS.
002930     MOVE SPACES TO LR.
002940     MOVE 'PROCESSING COMPLETE NORMAL EXIT' TO LR-2T32.
002950     WRITE LR AFTER POSITIONING 0.
002960     CLOSE LIST.
002970      STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. ISAMBLD.
000030 AUTHOR. RALPH BACK.
000040 INSTALLATION. THE BOEING COMPANY, HOUSTON, TX.
000050 DATE-WRITTEN. OCTOBER, 1968.
000060 REMARKS.    *** SNEAK CIRCUIT SYSTEM ***
000070             THIS PROGRAM READS THE BRANCH TABLE AND CREATES
000080         THE NODE TABLE. IN ADDITION, THE BRANCH TABLE AND THE
000090         NODE TABLE ARE WRITTEN ON DISK AS ISAM FILES WHICH
000100         WILL BE AVAILABLE FOR THE PATH DERIVATION PROGRAM.
000110             THIS PROGRAM WILL BE FOLLOWED BY THE UTILITY
000120         IEBISAM WHICH WILL UNLOAD THE BRANCH AND NODE TABLES
000130         ONTO TAPE.
000140 ENVIRONMENT DIVISION.
000150 CONFIGURATION SECTION.
000160 SOURCE-COMPUTER. IBM-360.
000170 OBJECT-COMPUTER. IBM-360.
000180 INPUT-OUTPUT SECTION.
000190 FILE-CONTROL.
000200     SELECT NODETBL          ASSIGN TO
000210     DA-2311-I-NODETBL ACCESS IS SEQUENTIAL
000220         RECORD KEY IS NODE-NO.
000230     SELECT BRNHTBL          ASSIGN TO
000240     DA-2311-I-BRNHTBL ACCESS IS SEQUENTIAL
000250         RECORD KEY IS BRANCH-NO.
000260     SELECT BRINPUT          ASSIGN TO UT-S-BRINPUT.
000270     SELECT SORTOUT          ASSIGN TO UT-S-SORTOUT.
000280     SELECT SORT-AREA ASSIGN TO UT-S-SD1.
000290 DATA DIVISION.
000300 FILE SECTION.
000310 FD  NODETBL
000320         LABEL RECORDS STANDARD
000330         RECORDING MODE F
000340         BLOCK CONTAINS  41  RECORDS
000350         DATA RECORD IS NODE-ENTRY.
000360 01  NODE-ENTRY.
000370     02  EXTRA-BYTE  PICTURE X.
000380     02  NODE-NO PICTURE X(12).
000390     02  NODE-ELE REDEFINES NODE-NO.
000400         03  NODE    PICTURE X(6).
000410         03  ELE     PICTURE 9(6).
000420     02  BRANCH  PICTURE X(6).
000430 FD  BRINPUT
000440         LABEL RECORDS OMITTED
000450         RECORDING MODE IS F
000460             BLOCK 100 RECORDS
000470         DATA RECORD IS BRANCH-REC.
000480 01  BRANCH-REC.
000490     02  BR-NO       PICTURE X(6).
000500     02  TABLE-DATA.
000510         03  FROM-NODE   PICTURE X(6).
000520         03  TO-NODE     PICTURE X(6).
000530         03  FILLER      PICTURE X(4).
000540     02  SWITCH      PICTURE X.
000550 FD  BRNHTBL
000560         LABEL RECORDS STANDARD
000570         RECORDING MODE F
000580         BLOCK CONTAINS 37 RECORDS
000590         DATA RECORD IS BRANCH-ENTRY.
000600 01  BRANCH-ENTRY.
000610     02  FLAG-BYTE   PICTURE X.
000620     02  BRANCH-NO   PICTURE X(6).
000630     02  BR-DATA     PICTURE X(16).
000640 FD  SORTOUT
000650         LABEL RECORDS OMITTED
000660         RECORDING MODE F
000670         BLOCK CONTAINS 61  RECORDS
000680         DATA RECORD IS SRT.
000690 01  SRT.
000700     02  NODEN       PICTURE X(6).
000710     02  FILLER      PICTURE X(6).
000720     02  BRANCHN     PICTURE X(6).
000730     02  CK-BYTE     PICTURE X.
000740 SD  SORT-AREA
000750     RECORDING MODE F
000760     DATA RECORD NODES.
000770 01  NODES.
000780     02  NN          PICTURE X(6).
000790     02  FILLER      PICTURE X(6).
000800     02  BRN         PICTURE X(6).
000810     02  CHECK-BYTE  PICTURE X.
000820 WORKING-STORAGE SECTION.
000830 77  LNN             PICTURE X(6).
000840 77  ELEN            PICTURE S9(6) COMPUTATIONAL.
000850 77  RBRT            PICTURE S9(6) COMPUTATIONAL.
000860 77  RNT             PICTURE S9(6) COMPUTATIONAL.
000870 PROCEDURE DIVISION.
000880     MOVE 0 TO RNT, RBRT.
000890     DISPLAY 'EXECUTION STATISTICAL INFORMATION'.
000900                             NOTE -------------------------------
000910                                 THE FOLLOWING SORT VERB WILL
000920                             SORT THE NODE TABLE ON THE NODE
000930                             FIELD
000940                             -----------------------------------.
000950     SORT SORT-AREA ON ASCENDING KEY NN BRN
000960         INPUT PROCEDURE CREATE-NODE-TABLE GIVING SORTOUT.
000970                             NOTE -------------------------------
000980                                 THE SORTED NODE TABLE IS NOW
000990                             ASSIGNED AN ELEMENT NUMBER AND EACH
001000                             NODE IS WRITTEN INTO AN ISAM DATA
001010                             SET
001020                             -----------------------------------.
001030     OPEN INPUT SORTOUT.
001040     OPEN OUTPUT NODETBL.
001050 READ-SORTED-NODE-TBL.
001060     READ SORTOUT AT END GO TO JOBEND.
001070 SW.
001080     GO TO INIT.
001090 INIT.
001100     MOVE NODEN TO LNN.
001110     MOVE 1 TO ELEN.
001120     ALTER SW TO PROCEED TO CONTINUE-PROCESS.
001130 CONTINUE-PROCESS.
001140     IF NODEN = LNN GO TO WRITE-NODE
001150         ELSE
001160     MOVE NODEN TO LNN,
001170     MOVE 1 TO ELEN.
001180 WRITE-NODE.
001190     MOVE NODEN TO NODE.
001200     MOVE ELEN TO ELE.
001210     MOVE BRANCHN TO BRANCH.
001220     MOVE CK-BYTE TO EXTRA-BYTE.
001230     WRITE NODE-ENTRY
001240         INVALID KEY
001250         DISPLAY '*** DESCENDING OR DUPLICATE RECORD *** KEY = '
001260                 NODE-NO,
001270         GO TO READ-SORTED-NODE-TBL.
001280     ADD 1 TO RNT.
001290     ADD 1 TO ELEN.
001300     GO TO READ-SORTED-NODE-TBL.
001310 JOBEND.
001320     CLOSE SORTOUT.
001330     CLOSE NODETBL.
001340     DISPLAY '           *** BRANCH TABLE ENTRIES = ' RBRT.
001350     DISPLAY '           *** NODE TABLE ENTRIES   = ' RNT.
001360     GOBACK.
001370 CREATE-NODE-TABLE SECTION.
001380     OPEN INPUT BRINPUT.
001390     OPEN OUTPUT BRNHTBL.
001400                             NOTE -------------------------------
001410                                 THIS SECTION READS THE BRANCH
001420                             TABLE AND CREATES THE NODE TABLE --
001430                             THE NODE TABLE IS CREATED BY TAKING
001440                             A RECORD FROM THE BRANCH TABLE
001450                             AND CREATING TWO ENTRIES IN THE NODE
001460                             TABLE -- ONE ENTRY CONTAINS THE
001470                             FROM NODE NUMBER AND THE BRANCH
001480                             NUMBER AND THE OTHER ENTRY CONTAINS
001490                             THE TO NODE NUMBER AND THE BRANCH
001500                             NUMBER -- EACH BRANCH TABLE ENTRY
001510                             IS WRITTEN INTO AN ISAM DATA SET
001520                             -----------------------------------.
001530 READ-BRANCH-TBL.
001540     READ BRINPUT AT END GO TO EX.
001550     MOVE BR-NO TO BRN.
001560     MOVE FROM-NODE TO NN.
001570     MOVE SPACE TO CHECK-BYTE.
001580     RELEASE NODES.
001590     MOVE TO-NODE TO NN.
001600     RELEASE NODES.
001610     MOVE BR-NO TO BRANCH-NO.
001620     MOVE SWITCH TO FLAG-BYTE.
001630     MOVE TABLE-DATA TO BR-DATA.
001640     WRITE BRANCH-ENTRY
001650         INVALID KEY
001660         DISPLAY '*** DESCENDING OR DUPLICATE RECORD *** KEY = '
001670                 BRANCH-NO,
001680         GO TO READ-BRANCH-TBL.
001690     ADD 1 TO RBRT.
001700     GO TO READ-BRANCH-TBL.
001710 EX.
001720     CLOSE BRINPUT.
001730     CLOSE BRNHTBL.
001740 GO-BACK.
001750     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. PATH.
000030 AUTHOR. RALPH BACK.
000040 INSTALLATION. THE BOEING COMPANY, HOUSTON, TX.
000050 DATE-WRITTEN. OCTOBER, 1968.
000060 REMARKS.    *** SNEAK CIRCUIT SYSTEM ***
000070             THIS PROGRAM WILL FIND PATHS IN THE FORM OF POWER TO
000080         GROUND, POWER TO POWER, AND GROUND TO GROUND
000090             THE PROGRAM WILL CONSIDER DIODE DIRECTION AND
000100         IMPEDANCE IN DETERMINING LEGAL PATHS
000110             DIRECT ACCESS TECHNIQUES ARE USED FOR TABLE LOOK UP
000120         PROCEDURES
000130             THE FOLLOWING PATHS WILL BE REPORTED
000140         (1) POWER TO POWER      IMPEDANCE=0,
000150         (2) POWER TO GROUND     0 GT IMPEDANCE LT MAX PATH IMP,
000160         (3) GROUND TO GROUND    0 GT IMPEDANCE LT MAX PATH IMP,
000170         (4) POWER TO GROUND     0 GT IMPEDANCE LT MAX PATH IMP.
000180         *********************************************************
000190         *              PROGRAM OPERATING PROCEDURE              *
000200         *                  MODES OF OPERATION                   *
000210         *                       NORMAL                          *
000220         *                       SELECTIVE                       *
000230         *                       RESTART                         *
000240         *   NORMAL - DERIVATION OF PATHS WILL START WITH BRANCH *
000250         *       1,2,ETC. THE FOLLOWING INFORMATION IS NECESSARY *
000260         *       ON THE CONTROL CARD - MAX PATH IMPEDANCE, MAX   *
000270         *       READ LIMIT, AND MAX PATH LIMIT.                 *
000280         *   SELECTIVE - DERIVATION OF PATHS WILL START WITH     *
000290         *       BRANCH N,N+1,ETC. THE FOLLOWING INFORMATION IS  *
000300         *       NECESSARY ON THE CONTROL CARD - MAX PATH        *
000310         *       IMPEDANCE, THE BRANCH TO START ON MINUS 1 (N-1),*
000320         *       MAX READ LIMIT, AND MAX PATH LIMIT.             *
000330         *   RESTART - DERIVATION OF PATHS WILL START WITH THE   *
000340         *       BRANCH THE PROGRAM WAS WORKING ON IN THE LAST   *
000350         *       RUN. THE FOLLOWING INFORMATION IS NECESSARY ON  *
000360         *       THE CONTROL CARD - MAX PATH IMPEDANCE, 'X' IN   *
000370         *       COLUMN 5, THE BRANCH TO RESTART WITH MINUS 1,   *
000380         *       MAX READ LIMIT, MAX PATH LIMIT, AND THE LAST    *
000390         *       PATH NUMBER REPORTED FROM LAST RUN.             *
000400         *                                                       *
000410         *           WHEN THE PROGRAM IS IN EITHER THE NORMAL OR *
000420         *       SELECTIVE MODE, A DATA SET REPRESENTED WITH THE *
000430         *       DDNAME 'ILLSR' IS CREATED. THE DISPOSITION      *
000440         *       PARAMETER MUST BE DISP=(,KEEP). WHEN THE        *
000450         *       PROGRAM IS IN THE RESTRAT MODE, THE DATA SET    *
000460         *       ALREADY EXISTS. THE DISPOSITION PARAMETER MUST  *
000470         *       BE DISP=OLD.                                    *
000480         ********************************************************.
000490 ENVIRONMENT DIVISION.
000500 CONFIGURATION SECTION.
000510 SOURCE-COMPUTER. IBM-360.
000520 OBJECT-COMPUTER. IBM-360.
000530 INPUT-OUTPUT SECTION.
000540 FILE-CONTROL.
000550     SELECT CONTROL-FILE ASSIGN TO UT-S-MAXIMP.
000560     SELECT  PATHS       ASSIGN TO UT-S-PATHRPT.
000570     SELECT ILLEGAL-SOURCES ASSIGN TO UT-S-ILLSR.
000580     SELECT  NODES       ASSIGN TO
000590         DA-2311-I-NODES ACCESS IS RANDOM
000600         RECORD KEY NODE,
000610         NOMINAL KEY NODE-KEY.
000620     SELECT  BRANCHES    ASSIGN TO
000630         DA-2311-I-BRANCHES ACCESS IS RANDOM
000640         RECORD KEY BRANCH,
000650         NOMINAL KEY BRANCH-NO.
000660 DATA DIVISION.
000670 FILE SECTION.
000680 FD  PATHS
000690         RECORDING MODE F
000700         LABEL RECORDS OMITTED
000710         BLOCK 50 RECORDS
000720         DATA RECORD IS PATH.
000730 01  PATH            PICTURE X(18).
000740 FD  ILLEGAL-SOURCES
000750         RECORDING MODE F
000760         LABEL RECORD OMITTED
000770         DATA RECORD SAVE-BRANCH.
000780 01  SAVE-BRANCH     PICTURE X(20).
000790 FD  NODES
000800         RECORDING MODE F
000810         BLOCK CONTAINS  41 RECORDS
000820         LABEL RECORDS STANDARD
000830         DATA RECORD NODE-ENTRY.
000840 01  NODE-ENTRY.
000850     02  FILLER  PICTURE X.
000860     02  NODE        PICTURE X(12).
000870     02  BRN         PICTURE 9(6).
000880 FD  BRANCHES
000890         RECORDING MODE F
000900         LABEL RECORDS STANDARD
000910         BLOCK CONTAINS  37 RECORDS
000920         DATA RECORD BRANCH-ENTRY.
000930 01  BRANCH-ENTRY.
000940     02  FLAG-BYTE   PICTURE X.
000950     02  BRANCH      PICTURE 9(6).
000960     02  FROM-NODE   PICTURE 9(6).
000970     02  TO-NODE     PICTURE 9(6).
000980     02  IMPEDANCE   PICTURE 99V9.
000990     02  DIODE       PICTURE X.
001000 FD  CONTROL-FILE
001010         RECORDING MODE F
001020         LABEL RECORDS OMITTED
001030         DATA RECORD MAX.
001040 01  MAX.
001050     02  MAX-IMP     PICTURE 99V9.
001060     02  FILLER      PICTURE X.
001070     02  RESTART     PICTURE X.
001080     02  LFBR        PICTURE 9(6).
001090     02  STBR REDEFINES LFBR PICTURE X(6).
001100     02  FILLER      PICTURE X.
001110     02  READ-LIMIT  PICTURE 9(5).
001120     02  FILLER      PICTURE X.
001130     02  BRANCH-LIMIT PICTURE 999.
001140     02  FILLER      PICTURE X.
001150     02  LPN         PICTURE 9(6).
001160     02  FILLER      PICTURE X(52).
001170 WORKING-STORAGE SECTION.
001180 77  WS-LOCATE       PICTURE X(8) VALUE 'PGM DATA'.
001190 77  PATH-NO         PICTURE S9(6) COMPUTATIONAL.
001200 77  NOOSE           PICTURE S9(8) COMPUTATIONAL.
001210 77  LOOP            PICTURE S9(8) COMPUTATIONAL.
001220 77  PGIZ            PICTURE S9(8) COMPUTATIONAL VALUE ZERO.
001230 77  PGINZ           PICTURE S9(8) COMPUTATIONAL VALUE ZERO.
001240 77  NRDBR   PICTURE S9(8) COMPUTATIONAL VALUE ZERO.
001250 77  NRDN    PICTURE S9(8) COMPUTATIONAL VALUE ZERO.
001260 77  MAXBR       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001270 77  OVFLW       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001280 77  NLIM        PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001290 77  IMPLIM      PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001300 77  NSBRS       PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001310 77  NSWS        PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001320 77   DIODE-VIOLATIONS    PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001330 77  X               PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001340 77  I       PICTURE S9(6) COMPUTATIONAL.
001350 77  J       PICTURE S9(6) COMPUTATIONAL.
001360 77  L       PICTURE S9(6) COMPUTATIONAL.
001370 77  PT      PICTURE S9(6) COMPUTATIONAL VALUE ZERO.
001380 77  NBR     PICTURE S9(6) COMPUTATIONAL.
001390 77  PATH-IMPEDANCE  PICTURE S99V9 COMPUTATIONAL.
001400 77  MAXIMUM-PATH-IMPEDANCE  PICTURE S99V9 COMPUTATIONAL.
001410 77  TREADS      PICTURE S9(6) COMPUTATIONAL.
001420 77  MAX-BRANCHES    PICTURE S9(6) COMPUTATIONAL.
001430 77  MAX-READS       PICTURE S9(6) COMPUTATIONAL.
001440 77  BRANCH-NO       PICTURE 9(6).
001450 77  PATH-DIODE      PICTURE X.
001460 77  FIRST-NODE      PICTURE 9(6).
001470 77  LAST-NODE       PICTURE 9(6).
001480 77  NODE-HOLD       PICTURE 9(6).
001490 77  START-BRANCH    PICTURE 9(6).
001500 77  LAST-FLAGGED-BRANCH PICTURE 9(6) VALUE ZERO.
001510 77  DIODE-HOLD      PICTURE X.
001520 77  LILBR   PICTURE 9(6) VALUE ZERO.
001530 01  WS-PATH.
001540     02  PATH-N      PICTURE 9(6).
001550     02  ELE-N       PICTURE 9(6).
001560     02  BR-N        PICTURE 9(6).
001570 01  NODE-KEY.
001580     02  NN          PICTURE X(6).
001590     02  KK          PICTURE X(6).
001600 01  SAVE-NODE-TABLE.
001610     02  NODE-TABLE OCCURS 502 TIMES.
001620         03  N       PICTURE 9(6).
001630         03  K       PICTURE 9(6).
001640 01  SAVE-BRANCH-TABLE.
001650     02  BRANCH-TABLE OCCURS 500 TIMES.
001660         03  BR          PICTURE 9(6).
001670         03  BR-DIODE    PICTURE X.
001680         03  BR-IMPEDANCE PICTURE 99V9.
001690         03  BR-SWITCH   PICTURE X.
001700 01  BRANCH-STORAGE.
001710     02  BRANCH-LIST OCCURS 1000 TIMES PICTURE 9(6).
001720 01  WS-SAVE-BRANCH.
001730     02 ILL-BR       PICTURE 9(6).
001740     02  SLACK-SPACE PICTURE X(14).
001750 01  EXHAUSTED-BRANCH-TABLE.
001760     02  EXHAUSTED-BRANCH OCCURS 5000 TIMES PICTURE 9(6).
001770 PROCEDURE DIVISION.
001780     MOVE 0 TO NOOSE, LOOP, PATH-NO, START-BRANCH.
001790     DISPLAY 'EXECUTION STATISTICAL INFORMATION'.
001800     OPEN INPUT CONTROL-FILE.
001810     READ CONTROL-FILE
001820         AT END
001830     DISPLAY ' ************ ABEND * NO CONTROL CARD ***',
001840     CLOSE CONTROL-FILE, STOP RUN.
001850                        NOTE -------------------------------
001860                                SEARCH CONSTRAINTS
001870                        (1) A PATH IS RESTRICTED TO A
001880                        MAXIMUM IMPEDANCE
001890                        (2) A PATH SOURCE BRANCH IS
001900                        RESTRICTED TO A MAXIMUM NUMBER OF
001910                        TABLE READS IN DERIVING ALL PATHS
001920                        FROM THAT SOURCE BRANCH
001930                        (3) A PATH IS RESTRICTED TO A
001940                        MAXIMUM NUMBER OF BRANCHES/PATH
001950                                CONTROL CARD FORMAT
001960                        (1) PATH IMPEDANCE (3 DIGITS)
001970                            COLUMNS 1-3
001980                        (2) RESTART (THE VALUE X IN COLUMN)
001990                            COLUMN 5
002000                        (3) STARTING BRANCH NO (6 DIGITS)
002010                            COLUMNS 6-11
002020                        (4) READ LIMIT (5 DIGITS)
002030                            COLUMNS 13-17
002040                        (5) BRANCH LIMIT (3 DIGITS)
002050                            COLUMNS 19-21
002060                        (6) LAST PATH NUMBER (6 DIGITS)
002070                            COLUMNS 23-28
002080                        -----------------------------------.
002090     MOVE MAX-IMP TO MAXIMUM-PATH-IMPEDANCE.
002100     MOVE READ-LIMIT TO MAX-READS.
002110     MOVE BRANCH-LIMIT TO MAX-BRANCHES.
002120     IF RESTART = 'X' GO TO RESTART-SEQUENCE.
002130                        NOTE -------------------------------
002140                                 THE FOLLOWING TEST WILL DETERMINE
002150                             IF THE PATH SEARCH WILL START WITH
002160                             THE FIRST POWER-NODE BRANCH OR ANY
002170                             GIVEN POWER-NODE BRANCH
002180                                 IF LFBR IS BLANK, THE PROGRAM
002190                             WILL START WITH THE FIRST POWER-NODE
002200                             BRANCH
002210                                 IF LFBR IS NOT BLANK, THE PROGRAM
002220                             WILL START WITH THE POWER-NODE BRANCH
002230                             INDICATED BY LFBR+1
002240                             -----------------------------------.
002250     IF STBR = SPACES
002260         MOVE 0 TO START-BRANCH
002270         ELSE
002280         MOVE LFBR TO START-BRANCH.
002290     GO TO NORMAL-START.
002300 RESTART-SEQUENCE.
002310     MOVE LPN TO PATH-NO.
002320     MOVE LFBR TO START-BRANCH, LAST-FLAGGED-BRANCH.
002330     OPEN INPUT ILLEGAL-SOURCES.
002340     MOVE 1 TO PT.
002350 RELOAD-TABLE.
002360     READ ILLEGAL-SOURCES INTO WS-SAVE-BRANCH
002370         AT END GO TO TABLE-REBUILT.
002380     IF ILL-BR = LILBR GO TO RELOAD-TABLE.
002390     MOVE ILL-BR TO LILBR.
002400                             NOTE -------------------------------
002410                                 IF THIS PROGRAM IS RESTARTED,
002420                             THE BRANCH-LIST ARRAY IS REBUILT
002430                             FROM THE DATA SAVED ON TAPE FROM
002440                             PREVIOUS RUN
002450                                 DUE TO LIMITATIONS WITH COBOL,
002460                             THE REBUILT TABLE MUST BE REWRITTEN
002470                             ON TAPE
002480                             -----------------------------------.
002490     MOVE ILL-BR TO BRANCH-LIST (PT).
002500     COMPUTE PT = PT + 1.
002510     IF PT GREATER 1000
002520         DISPLAY 'BRANCH-STORAGE TABLE FILLED WHILE REBUILDING',
002530         GO TO TABLE-REBUILT.
002540     GO TO RELOAD-TABLE.
002550 TABLE-REBUILT.
002560     CLOSE ILLEGAL-SOURCES.
002570     COMPUTE PT = PT - 1.
002580     MOVE 1 TO L.
002590     OPEN OUTPUT ILLEGAL-SOURCES.
002600 REWRITE-TABLE.
002610     MOVE BRANCH-LIST (L) TO ILL-BR.
002620     MOVE SPACES TO SLACK-SPACE.
002630     WRITE SAVE-BRANCH FROM WS-SAVE-BRANCH.
002640     WRITE SAVE-BRANCH FROM WS-SAVE-BRANCH.
002650     COMPUTE L = L + 1.
002660     IF L GREATER PT GO TO CONTINUE-DERIVATION.
002670     GO TO REWRITE-TABLE.
002680 NORMAL-START.
002690     OPEN OUTPUT ILLEGAL-SOURCES.
002700 CONTINUE-DERIVATION.
002710     CLOSE CONTROL-FILE.
002720     OPEN I-O BRANCHES.
002730     OPEN I-O NODES.
002740     OPEN OUTPUT PATHS.
002750 NEW-BRANCH.
002760     COMPUTE START-BRANCH = START-BRANCH + 1
002770     IF PT = 0 GO TO LEGAL-BRANCH.
002780                             NOTE -------------------------------
002790                                 WHEN A BRANCH-NO IS USED AS AN
002800                             END BRANCH, THIS BRANCH WILL BE
002810                             STORED IN BRANCH-LIST AND THIS LIST
002820                             WILL BE SEARCHED EVERY TIME A NEW
002830                             BRANCH IS SELECTED TO START A PATH
002840                                 IF THE SELECTED BRANCH APPEARS
002850                             IN BRANCH-LIST, IT WILL NOT BE USED
002860                             TO START A PATH AND THE NEXT BRANCH
002870                             WILL BE SELECTED AND THE PROCEDURE
002880                             REPEATED UNTIL A LEGAL BRANCH IS
002890                             FOUND TO START A PATH
002900                             -----------------------------------.
002910     MOVE 1 TO L.
002920 SEARCH-LIST.
002930     IF START-BRANCH = BRANCH-LIST (L) GO TO NEW-BRANCH.
002940     COMPUTE L = L + 1.
002950     IF L GREATER PT GO TO LEGAL-BRANCH
002960         ELSE
002970     GO TO SEARCH-LIST.
002980 LEGAL-BRANCH.
002990     MOVE START-BRANCH TO BRANCH-NO.
003000 FIND-BRANCH.
003010     READ BRANCHES
003020         INVALID KEY
003030                     DISPLAY 'INVALID BRANCH KEY ' BRANCH-NO
003040                     GO TO JOBEND.
003050     COMPUTE NRDBR = NRDBR + 1.
003060     COMPUTE TREADS = TREADS + 1.
003070     IF BRANCH LESS LAST-FLAGGED-BRANCH  OR = LAST-FLAGGED-BRANCH
003080         GO TO BACK-UP.
003090                             NOTE -------------------------------
003100                                 A CHECK IS MADE SEE WHETHER OR
003110                             NOT A POWER-NODE BRANCH HAS GIVEN
003120                             ALL POSSIBLE PATHS
003130                                 THIS CHECK IS MADE SO THAT THE
003140                             REVERSE OF A PATH IS NOT REPORTED
003150                                 IF A FLAGGED BRANCH IS FOUND,
003160                             THE BRANCH CANNOT BE USED, THEREFOR
003170                             ANOTHER NODE WILL BE SELECTED
003180                             -----------------------------------.
003190 SW.
003200     GO TO START-PATH.
003210 START-PATH.
003220     MOVE 0 TO X.
003230     IF FROM-NODE GREATER 1 GO TO JOBEND.
003240                             NOTE -------------------------------
003250                                 AS EACH POWER-NODE IS SELECTED
003260                             FOR THE FIRST TIME, A CHECK IS MADE
003270                             TO SEE IF THE FROM-NODE IS GREATER
003280                             THAN 1
003290                             IF THIS CONDITION EXISTS, THE
003300                             PROGRAM HAS EXHAUSTED ALL STARTING
003310                             POINTS AND THE JOB IS ENDED
003320                             -----------------------------------.
003330     COMPUTE NSBRS = NSBRS + 1.
003340     COMPUTE TREADS = 0.
003350     MOVE '0' TO PATH-DIODE.
003360     MOVE 0 TO PATH-IMPEDANCE.
003370     MOVE FROM-NODE TO FIRST-NODE.
003380     COMPUTE I = 1.
003390     COMPUTE J = 2.
003400                             NOTE -------------------------------
003410                                 THROUGHOUT THIS JOB STEP, THE
003420                             DATA NAMES I AND J ARE USED AS
003430                             SUBSCRIPTS
003440                                 I REPRESENTS THE INDEX TO THE
003450                             SAVE-BRANCH-TABLE AND J REPRESENTS
003460                             THE INDEX TO THE SAVE-NODE-TABLE
003470                                 THE INDEX TO THE SAVE-NODE-TABLE
003480                             AT ANY TIME DURING EXECUTION WILL BE
003490                             AT MOST ONE GREATER THAN THE INDEX
003500                             TO THE SAVE-BRANCH-TABLE, THERFORE
003510                             BY CHECKING THE DIMENSION OF THE
003520                             SAVE-BRANCH-TABLE, THE SAVE-NODE-
003530                             TABLE WILL NEVER EXCEED ITS
003540                             DIMENSION
003550                             -----------------------------------.
003560     MOVE BRANCH TO BR (I).
003570     MOVE TO-NODE TO N (J).
003580                             NOTE -------------------------------
003590                                 AS EACH POWER-NODE SEGMENT IS
003600                             SELECTED, THE BRANCH NUMBER IS PUT
003610                             IN THE SAVE-BRANCH-TABLE, AND THE
003620                             NODE NUMBER IS PUT IN THE SAVE-NODE-
003630                             TABLE
003640                                 THIS IS AN INITIALIZATION STEP
003650                             -----------------------------------.
003660     MOVE DIODE TO BR-DIODE (I), PATH-DIODE.
003670     MOVE IMPEDANCE TO BR-IMPEDANCE (I).
003680     MOVE FLAG-BYTE TO BR-SWITCH (I).
003690     MOVE 1 TO K (J).
003700     COMPUTE PATH-IMPEDANCE = PATH-IMPEDANCE + BR-IMPEDANCE (I).
003710     MOVE N (J) TO NN.
003720     MOVE K (J) TO KK.
003730     ALTER SW TO PROCEED TO TEST-BRANCH-NODES.
003740 FIND-NODE.
003750     READ NODES
003760         INVALID KEY GO TO STORE-EX-BR.
003770     COMPUTE NRDN = NRDN + 1.
003780     COMPUTE TREADS = TREADS + 1.
003790                             NOTE ------------------------------
003800                                 THE DERIVATION OF A PATH WILL BE
003810                             TERMINATED IF THE TOTAL NUMBER OF
003820                             READS FOR BOTH THE BRANCH AND NODE
003830                             TABLES EXCEEDS MAX-READS, A NEW
003840                             SOURCE BRANCH IS THEN SELECTED
003850                             -----------------------------------.
003860     IF TREADS GREATER MAX-READS
003870         COMPUTE TREADS = 0,
003880         COMPUTE NLIM = NLIM + 1,
003890         ALTER SW TO PROCEED TO START-PATH,
003900         GO TO NEW-BRANCH.
003910     MOVE 1 TO L.
003920 TESTR.
003930     IF BRN = BR (L)
003940                 COMPUTE K (J) = K (J) + 1,
003950                 MOVE K (J) TO KK,
003960                 GO TO FIND-NODE.
003970     COMPUTE L = L + 1.
003980     IF L GREATER I NEXT SENTENCE ELSE GO TO TESTR.
003990     MOVE 1 TO L.
004000 EXBR-TEST.
004010     IF X = 0 GO TO NO-EXBR-TST.
004020     IF BRN = EXHAUSTED-BRANCH (L)
004030         MOVE 999999 TO LAST-NODE
004040         GO TO TEST-PATH.
004050     COMPUTE L = L + 1.
004060     IF L GREATER X NEXT SENTENCE
004070         ELSE GO TO EXBR-TEST.
004080 NO-EXBR-TST.
004090     COMPUTE I = I + 1.
004100     IF I GREATER MAX-BRANCHES
004110         COMPUTE OVFLW = OVFLW + 1,
004120         GO TO BACK-UP.
004130                             NOTE -------------------------------
004140                                 THE MAXIMUM NUMBER OF BRANCHES
004150                             PER PATH IS SET BY THE PARAMETER
004160                             MAX-BRANCHES
004170                                 IF THIS MAX IS EXCEEDED, A COUNT
004180                             (OVFLW) IS KEPT INDICATING THE NUMBER
004190                             OF PATHS THAT EXCEEDED THE BRANCH-
004200                             PATH LIMIT
004210                                 THE BACK-UP PROCEDURE IS THEN
004220                             EXECUTED
004230                             -----------------------------------.
004240     MOVE BRN TO BR (I), BRANCH-NO.
004250     GO TO FIND-BRANCH.
004260                             NOTE -------------------------------
004270                                 THE SAVE-BRANCH-TABLE IS
004280                             SEARCHED TO SEE IF THE BRANCH FROM
004290                             THE LAST NODE IS IN THE TABLE, IF IT
004300                             IS NOT, THE BRANCH NUMBER IS PUT IN
004310                             THE TABLE AND THE BRANCH IS READ
004320                             FROM THE BRANCH TABLE
004330                                 THE NODES OF THE BRANCH ARE THEN
004340                             CHECKED FOR DIODE, IMPEDANCE, AND
004350                             POSSIBLE LOOPS
004360                             -----------------------------------.
004370 TEST-BRANCH-NODES.
004380     IF FROM-NODE = N (J)
004390                 MOVE TO-NODE TO NODE-HOLD
004400                 GO TO LOOK-UP-NODE.
004410     IF TO-NODE = N (J)
004420                 MOVE FROM-NODE TO NODE-HOLD
004430                 GO TO LOOK-UP-NODE.
004440                             NOTE -------------------------------
004450                                 IF NEITHER CONDITION ABOVE IS
004460                             SATISFIED, AN ERROR CONDITION EXISTS
004470                             AND THE JOB WILL BE ENDED
004480                             -----------------------------------.
004490     DISPLAY '       *** TABLE ERROR -- JOB ENDED ***'.
004500     GO TO JOBEND.
004510 LOOK-UP-NODE.
004520     IF J GREATER 3 NEXT SENTENCE ELSE GO TO BAD-NODE.
004530     IF NODE-HOLD = N (2)
004540                     ALTER NLSW TO PROCEED TO A-NOOSE,
004550                     PERFORM VALIDATE-NOOSE-OR-LOOP,
004560                     GO TO BACK-UP.
004570 BAD-NODE.
004580     IF J GREATER 2 NEXT SENTENCE ELSE GO TO SEARCH-NODE-TABLE.
004590     COMPUTE L = J - 1.
004600     IF NODE-HOLD = N (L) GO TO BACK-UP.
004610 SEARCH-NODE-TABLE.
004620     MOVE 2  TO L.
004630 TEST-FOR-LOOP.
004640     IF NODE-HOLD = N (L)
004650                     ALTER NLSW TO PROCEED TO A-LOOP,
004660                     PERFORM VALIDATE-NOOSE-OR-LOOP,
004670                     GO TO BACK-UP.
004680     COMPUTE L = L + 1.
004690     IF L GREATER J NEXT SENTENCE ELSE GO TO TEST-FOR-LOOP.
004700     COMPUTE J = J + 1.
004710     MOVE NODE-HOLD TO N (J).
004720     MOVE 1 TO K (J).
004730     MOVE N (J) TO NN.
004740     MOVE K (J) TO KK.
004750     MOVE IMPEDANCE TO BR-IMPEDANCE (I).
004760     MOVE DIODE TO BR-DIODE (I).
004770     MOVE FLAG-BYTE TO BR-SWITCH (I).
004780 TEST-IMPEDANCE.
004790     COMPUTE PATH-IMPEDANCE = PATH-IMPEDANCE + BR-IMPEDANCE (I).
004800     IF PATH-IMPEDANCE GREATER MAXIMUM-PATH-IMPEDANCE
004810         COMPUTE IMPLIM = IMPLIM + 1,
004820             GO TO NODE-END.
004830 TEST-DIODE-DIRECTION.
004840     IF FROM-NODE = NODE-HOLD AND DIODE NOT = '0' NEXT SENTENCE
004850             ELSE
004860         GO TO CHECK-DIODE.
004870     IF DIODE = '+' MOVE '-' TO BR-DIODE (I),
004880             ELSE
004890         MOVE '+' TO BR-DIODE (I).
004900 CHECK-DIODE.
004910         GO  TO  DIODE-OK.
004920     IF BR-DIODE (I) = PATH-DIODE GO TO DIODE-OK.
004930     IF PATH-DIODE = '0'
004940         MOVE BR-DIODE (I) TO PATH-DIODE,
004950         GO TO DIODE-OK.
004960     IF BR-DIODE (I) = '0'
004970         MOVE PATH-DIODE TO BR-DIODE (I),
004980         GO TO DIODE-OK.
004990     COMPUTE DIODE-VIOLATIONS = DIODE-VIOLATIONS + 1.
005000     GO TO NODE-END.
005010 DIODE-OK.
005020     IF BR-SWITCH (I) = 'S' NEXT SENTENCE
005030         ELSE GO TO NOT-SW-BRANCH.
005040                             NOTE -------------------------------
005050                                 THIS IS THE SWITCH TEST - TWO
005060                             CONSECUTIVE BRANCHES OF A PATH MAY
005070                             NOT CONSIST OF SWITCH NODES
005080                                 IF THE CONDITION EXISTS, ANOTHER
005090                             BRANCH IS SELECTED
005100                             -----------------------------------.
005110     COMPUTE L = I - 1.
005120     IF BR-SWITCH (L) = 'S'
005130         COMPUTE NSWS = NSWS + 1
005140         GO TO NODE-END.
005150 NOT-SW-BRANCH.
005160     IF NODE-HOLD = 1 OR = 2 MOVE NODE-HOLD TO LAST-NODE
005170         ELSE
005180     GO TO FIND-NODE.
005190     IF FIRST-NODE = LAST-NODE NEXT SENTENCE
005200         ELSE
005210     GO TO WRITE-PATH.
005220     IF PT = 0 GO TO STORE-BRANCH.
005230                             NOTE -------------------------------
005240                                 THE LAST BRANCH CONTAINS A
005250                             POWER OR GROUND NODE THEREFORE THE
005260                             PATH TERMINATES
005270                                 IF THE END BRANCH IS IN BRANCH-
005280                             LIST, DO NOT STORE IN BRANCH-LIST
005290                             OTHERWISE STORE THE BRANCH IN
005300                             BRANCH-LIST, AND ALSO WRITE THE END
005310                             BRANCH ON TAPE FOR RESTART PROCEDURE
005320                             -----------------------------------.
005330     MOVE 1 TO L.
005340 LIST-CHECK.
005350     IF BR (I) = BRANCH-LIST (L) GO TO WRITE-PATH.
005360     COMPUTE L = L + 1.
005370     IF L GREATER PT GO TO STORE-BRANCH
005380         ELSE
005390     GO TO LIST-CHECK.
005400 STORE-BRANCH.
005410     COMPUTE PT = PT + 1.
005420     IF PT GREATER 1000
005430         DISPLAY 'BRANCH-LIST OVERFLOW', GO TO WRITE-PATH.
005440     MOVE BR (I) TO BRANCH-LIST (PT).
005450     MOVE SPACES TO SLACK-SPACE.
005460     MOVE BR (I) TO ILL-BR.
005470     WRITE SAVE-BRANCH FROM WS-SAVE-BRANCH.
005480     WRITE SAVE-BRANCH FROM WS-SAVE-BRANCH.
005490     GO TO WRITE-PATH.
005500                             NOTE -------------------------------
005510                                 THE FOLLOWING SEQUENCE IS THE
005520                             PROCEDURE USED TO BACK UP IN A PATH
005530                             ------------------------------------.
005540 STORE-EX-BR.
005550     COMPUTE X = X + 1.
005560     IF X GREATER 5000
005570         DISPLAY 'EXHAUSTED BRANCH TABLE OVERFLOW'
005580         GO TO JOBEND.
005590     MOVE BR (I) TO EXHAUSTED-BRANCH (X).
005600 NODE-END.
005610     COMPUTE J = J - 1.
005620     IF J = 1 GO TO FLAG-BRANCH.
005630                             NOTE -------------------------------
005640                                 BEFORE FINDING THE NEXT NODE,
005650                             A TEST IS MADE TO SEE IF ALL
005660                             BRANCHES FROM A POWER-NODE HAVE BEEN
005670                             FOUND, IF J EQUALS 1 WE ARE READY TO
005680                             GET THE NEXT POWER-NODE BRANCH
005690                             -----------------------------------.
005700     MOVE N (J) TO NN.
005710 DIODE-STOP.
005720     COMPUTE L = I - 1.
005730     IF BR-DIODE (L) NOT = PATH-DIODE
005740         MOVE BR-DIODE (L) TO PATH-DIODE.
005750 IMPEDANCE-CHECK.
005760     COMPUTE PATH-IMPEDANCE = PATH-IMPEDANCE - BR-IMPEDANCE (I).
005770 BACK-UP.
005780     COMPUTE I = I - 1.
005790     COMPUTE K (J) = K (J) + 1.
005800     MOVE K (J) TO KK.
005810     GO TO FIND-NODE.
005820                             NOTE -------------------------------
005830                                 THE FOLLOWING PROCEDURE IS
005840                             FOLLOWED WHEN A PATH IS FOUND AND
005850                             READY FOR POSSIBLE OUTPUT
005860                                 A PATH FOUND IN THE ORDER
005870                             GROUND/POWER WILL BE WRITTEN OUT IN
005880                             POWER/GROUND ORDER
005890                             -----------------------------------.
005900 WRITE-PATH.
005910     IF FIRST-NODE = LAST-NODE
005920         GO TO TEST-PATH.
005930     IF PATH-IMPEDANCE = 0
005940         COMPUTE PGIZ = PGIZ + 1
005950         ELSE
005960         COMPUTE PGINZ = PGINZ + 1.
005970 TEST-PATH.
005980     MOVE 1 TO L.
005990     COMPUTE PATH-NO = PATH-NO + 1.
006000     MOVE I TO NBR.
006010     IF I GREATER MAXBR MOVE I TO MAXBR.
006020     IF FIRST-NODE GREATER LAST-NODE
006030         ALTER DIR-SW TO PROCEED TO REVERSE-PATH
006040         ELSE
006050         ALTER DIR-SW TO PROCEED TO DIR-OK.
006060 WRITE-BRANCH.
006070     MOVE PATH-NO TO PATH-N.
006080     MOVE L TO ELE-N.
006090 DIR-SW.
006100     GO TO.
006110 DIR-OK.
006120     MOVE BR (L) TO BR-N.
006130     WRITE PATH FROM WS-PATH.
006140     COMPUTE L = L + 1.
006150     IF L GREATER NBR
006160         GO TO NODE-END.
006170     GO TO WRITE-BRANCH.
006180 REVERSE-PATH.
006190     MOVE BR (NBR) TO BR-N.
006200     WRITE PATH FROM WS-PATH.
006210     COMPUTE NBR = NBR - 1.
006220     IF NBR = 0
006230         GO TO NODE-END.
006240     COMPUTE L = L + 1.
006250     GO TO WRITE-BRANCH.
006260 FLAG-BRANCH.
006270     MOVE BR (1) TO LAST-FLAGGED-BRANCH.
006280                             NOTE -------------------------------
006290                                 WHEN A BRANCH IS FLAGGED, THIS
006300                             INDICATES THIS BRANCH, A POWER-NODE
006310                             OR GROUND-NODE BRANCH, HAS
006320                             ORIGINATED ALL PATHS FROM ITSELF
006330                             -----------------------------------.
006340     ALTER SW TO PROCEED TO START-PATH.
006350     GO TO NEW-BRANCH.
006360 JOBEND.
006370     CLOSE PATHS.
006380     CLOSE NODES.
006390     CLOSE BRANCHES.
006400     CLOSE ILLEGAL-SOURCES.
006410     DISPLAY 'LOOPS = ' LOOP.
006420     DISPLAY 'NOOSES = ' NOOSE.
006430     DISPLAY 'POWER-GROUND ZERO IMPEDANCE = ' PGIZ.
006440     DISPLAY 'POWER-GROUND NON-ZERO IMPEDANCE = ' PGINZ.
006450     DISPLAY 'TOTAL NUMBER OF PATHS REPORTED = ' PATH-NO.
006460     DISPLAY 'READS - NODE TABLE = ' NRDN.
006470     DISPLAY 'READS - BRANCH TABLE = ' NRDBR.
006480     DISPLAY 'MAXIMUM BRANCHES/PATH = ' MAXBR.
006490     DISPLAY 'NO. PATHS EXCEEDING MAX BRANCH/PATH LIMIT= ' OVFLW.
006500     DISPLAY 'NO. PATHS EXCEEDED READ-LIMIT= ' NLIM.
006510     DISPLAY 'NO. TIMES IMPEDANCE LIMIT EXCEEDED = ' IMPLIM.
006520     DISPLAY 'NO. SOURCE BRANCHES USED THIS RUN = ' NSBRS.
006530     DISPLAY 'DIODE VIOLATIONS = ' DIODE-VIOLATIONS.
006540     DISPLAY 'CONSECUTIVE SWITCHES FOUND = ' NSWS.
006550     STOP RUN.
006560 VALIDATE-NOOSE-OR-LOOP SECTION.
006570     IF DIODE = '0' GO TO NLSW.
006580                             NOTE -------------------------------
006590                                 IF A POTENTIAL LOOP OR NOOSE
006600                             CONDITION EXISTS, THIS SECTION IS
006610                             EXECUTED TO VALIDATE THE DIODE
006620                             DIRECTION OF THE BRANCH WHICH WILL
006630                             FORM THE NOOSE OR LOOP, THE LAST
006640                             BRANCH ADDED TO THE PATH
006650                                 A COUNT IS KEEP OF ALL VALID
006660                             LOOPS AND NOOSES
006670                             -----------------------------------.
006680     MOVE DIODE TO DIODE-HOLD.
006690     IF FROM-NODE = NODE-HOLD NEXT SENTENCE ELSE GO TO DIO-TEST.
006700     IF DIODE-HOLD = '+' MOVE '-' TO DIODE-HOLD
006710         ELSE
006720     MOVE '+' TO DIODE-HOLD.
006730 DIO-TEST.
006740     IF DIODE-HOLD = PATH-DIODE NEXT SENTENCE
006750         ELSE
006760     GO TO SEC-EXIT.
006770 NLSW.
006780     GO TO.
006790 A-NOOSE.
006800     COMPUTE NOOSE = NOOSE + 1.
006810     GO TO REPORT-LOOP.
006820 A-LOOP.
006830     COMPUTE LOOP = LOOP + 1.
006840 REPORT-LOOP.
006850     MOVE 1 TO L.
006860     COMPUTE PATH-NO = PATH-NO + 1.
006870     COMPUTE NBR = I - 1.
006880 WRITE-LOOP.
006890     MOVE PATH-NO TO PATH-N.
006900     MOVE L TO ELE-N.
006910     MOVE BR (L) TO BR-N.
006920     WRITE PATH FROM WS-PATH.
006930     COMPUTE L = L + 1.
006940     IF L GREATER NBR GO TO SEC-EXIT.
006950     GO TO WRITE-LOOP.
006960 SEC-EXIT.
006970     EXIT.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. RECFIX.
000030 REMARKS.  THIS PROGRAM INPUTS A TOTAL PATH AND LOADS IT INTO THE
000040          ARRAY IN ORDER TO GIVE THE PATHS CONTINUITY FOR LATER
000050          PRINTING IN THE FINAL REPORT PROGRAM.
000060
000070          AFTER PROCESSING THE PATH IS WRITTEN ON THE OUTPUT UNIT
000080
000090          PATH CONTINUITY IS DEFINED BY THE FROM NODE WHICH IS
000100          REPORTED IN FINAL REPORT ALONG WITH OTHER PERTINENT
000110          INFORMATION.
000120
000130          EXAMPLE 1  DEFINES A PROBABLE INPUT PATH
000140          EXAMPLE 2  DEFINES THE SAME OUTPUT PATH
000150
000160     PTH ELM BEG END FROM    TO  DIO SWIT DATA
000170
000180      1   1  150  1  CB1-1   PWR   0       XXXXXXXXXXXXXXXXXXXXXXX
000190      1   2  150 151 CB1-1   CB1-2 0   S   XXXXXXXXXXXXXXXXXXXXXXX
000200      1   3  190 151 CB1-2   J15-1 +       XXXXXXXXXXXXXXXXXXXXXXX
000210      1   4  190  1  J15-1   PWR           XXXXXXXXXXXXXXXXXXXXXXX
000220
000230      1   1   1  150 PWR     CB1-1 0       XXXXXXXXXXXXXXXXXXXXXXX
000240      1   2  150 151 CB1-1   CB1-2 0   S   XXXXXXXXXXXXXXXXXXXXXXX
000250      1   3  151 190 CB1-2   J15-1 +       XXXXXXXXXXXXXXXXXXXXXXX
000260      1   4  190  1  J15-1   PWR   0       XXXXXXXXXXXXXXXXXXXXXXX
000270      1   5   1  190 PWR     J15-1
000280
000290         NOTE THAT AN EXTRA SEGMENT IS GENERATED (ELM = 5)
000300
000310         INCOMPLETE PATHS HAVE TWO (2) EXTRA SEGMENTS GENERATED
000320             WITH N+1 =  DUMMY GND AND BEG-N01 (N+1) = 2
000330
000340         THE PATH CATEGORIES ARE
000350             1.  POWER TO POWER      =    1
000360             2.  POWER TO GROUND     =    2
000370             3.  GROUND TO GROUND    =    3
000380             4.  INCOMPLETE PATHS    =    4
000390 AUTHOR. A GUILLORY.
000400 ENVIRONMENT DIVISION.
000410 CONFIGURATION SECTION.
000420 SOURCE-COMPUTER. IBM-360.
000430 OBJECT-COMPUTER. IBM-360.
000440 INPUT-OUTPUT SECTION.
000450 FILE-CONTROL.
000460     SELECT PATHIN         ASSIGN UT-S-INPTH.
000470     SELECT PATHOUT              ASSIGN UT-S-OUTPATH.
000480 DATA DIVISION.
000490 FILE SECTION.
000500 FD  PATHIN
000510             RECORDING MODE F
000520             LABEL RECORD OMITTED
000530             BLOCK 10  RECORDS
000540             DATA RECORD IN-PTH.
000550 01  IN-PTH SYNC.
000560     02  FILLER          PICTURE  9(6).
000570     02  FILLER          PICTURE  9(6).
000580     02  FILLER          PICTURE  9(6).
000590     02  FILLER          PICTURE  9(6).
000600     02  FILLER          PICTURE  9(6).
000610         02  FILLER      PICTURE X(150).
000620 FD  PATHOUT
000630             RECORDING MODE F
000640             LABEL RECORD OMITTED
000650             BLOCK 10  RECORDS
000660             DATA RECORD PATHOUTS.
000670 01  PATHOUTS SYNC.
           02  FILLER  PIC 9.
000680     02  FILLER          PICTURE  9(6).
000690     02  FILLER          PICTURE  9(6).
000700     02  FILLER          PICTURE  9(6).
000710     02  FILLER          PICTURE  9(6).
000720     02  FILLER          PICTURE  9(6).
000730     02  FILLER          PICTURE  X(150).
000740 WORKING-STORAGE SECTION.
000750 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000760 77  CK-FLP              PICTURE 9(6) VALUE ZERO.
000770 77  TOT-PTHS            PICTURE 9(6) VALUE ZERO.
000780 77  NO-BAD-PTHS         PICTURE 9(6) VALUE ZERO.
000790 77  I                   PICTURE 9(6)   VALUE ZERO.
000800 77  J                   PICTURE 9(6)   VALUE ZERO.
000810 77  K                   PICTURE 9(6)   VALUE ZERO.
000820 77  TEMP-HOLD           PICTURE 9(6)   VALUE ZERO.
000830 77  ALL-P               PICTURE 9      VALUE ZERO.
000840 77  TYPE-PATH           PICTURE 9   VALUE ZERO.
000850 77  TEMP-HOLD1          PICTURE X(16).
000860 77  TEMP-DIO                PICTURE X VALUE  SPACE.
000870 01  PATH-IN.
000880     02  ARRAY1  OCCURS  100  TIMES.
000890         03  P-NO1       PICTURE 9(6).
000900         03  E-NO1       PICTURE 9(6).
000910         03  BRA-NO1     PICTURE 9(6).
000920         03  BEG-NO1     PICTURE 9(6).
000930         03  END-NO1     PICTURE 9(6).
000940         03  A-SWITCH    PICTURE X.
000950         03  BOX-A1      PICTURE X(15).
000960         03  FROM-C      PICTURE X(16).
000970         03  TO-C        PICTURE X(16).
000980         03  A-DIO           PICTURE X.
000990         03  DATA-A1     PICTURE X(101).
001000         03  CATOG1      PICTURE 99.
001010         03  TREE1       PICTURE X(6).
001020 01  PATH-HOLD.
001030       02  PATH-N        PICTURE 9(6).
001040       02  FILLER        PICTURE 9(12).
001050       02  FILLER        PICTURE 9(12).
001060       02  FILLER        PICTURE X(150).
001070 01  PATH-OUT-HOLD.
001080     02  TYP-P-OUT       PICTURE 9.
001090     02  P-NO-OUT        PICTURE 9(6).
001100     02  E-NO-OUT        PICTURE 9(6).
001110     02  BR-N-OUT        PICTURE 9(6).
001120     02  BG-NO-OUT       PICTURE 9(6).
001130     02  EN-N-OUT        PICTURE 9(6).
001140     02  SWIT-OUT        PICTURE X.
001150     02  BOX-OUT         PICTURE X(15).
001160     02  FROM-OUT            PICTURE X(16).
001170      02 TO-OUT               PICTURE X(16).
001180      02 OUT-DIO             PICTURE X.
001190     02  DATA-OUT        PICTURE X(101).
001200 PROCEDURE DIVISION.
001210     MOVE  1  TO  J.
001220     OPEN INPUT PATHIN.
001230     OPEN OUTPUT PATHOUT.
001240     MOVE  0  TO  I.
001250     MOVE  1  TO  J.
001260     MOVE  0  TO  ALL-P.
001270 RD-1.
001280     IF  ALL-P  =  5  GO TO STOP-ALL.
001290     READ PATHIN INTO PATH-HOLD AT END MOVE 5  TO ALL-P
001300             GO  TO  GOOD-PATH.
001310     IF I = 0
001320         MOVE 1 TO I
001330         MOVE PATH-HOLD TO ARRAY1 (I)
001340         GO TO RD-1.
001350     IF PATH-N = P-NO1 IN ARRAY1 (I)  NEXT SENTENCE ELSE
001360             GO  TO  GOOD-PATH.
001370     ADD  1  TO  I.
001380     IF  I   >   100
001390         DISPLAY  '  NEED  MORE  ARRAY1  SPACE  '
001400         GO  TO  STOP-ALL.
001410     MOVE  PATH-HOLD  TO  ARRAY1 (I).
001420     GO  TO  RD-1.
001430 GOOD-PATH.
001440     MOVE  1  TO  J.
001450     MOVE  2  TO  K.
001460     NOTE -------1------------------------------------------------
001470
001480             THIS PROCEDURE CHECKS TO MAKE SURE FROM CONN (1) IS A
001490             POWER OR GROUND     IF ELEMENTS ARE FLIPPED  +  DIODE
001500             MUST BE CHANGED TO  -   AND  -  TO  +
001510
001520          -------------------------------------------------------.
001530     IF  BEG-NO1  IN  ARRAY1 (J)  >  END-NO1  IN ARRAY1 (J)
001540           MOVE END-NO1 IN ARRAY1 (J)  TO TEMP-HOLD
001550           MOVE  TO-C  IN ARRAY1 (J)  TO  TEMP-HOLD1
001560           MOVE BEG-NO1 IN ARRAY1 (J)  TO END-NO1 IN  ARRAY1 (J)
001570           MOVE  FROM-C IN  ARRAY1 (J)  TO  TO-C IN ARRAY1 (J)
001580             MOVE  TEMP-HOLD1  TO  FROM-C  IN  ARRAY1 (J)
001590           MOVE  TEMP-HOLD TO BEG-NO1  IN  ARRAY1 (J)
001600           MOVE  J  TO  CK-FLP
001610           MOVE A-DIO (J)  TO  TEMP-DIO
001620           PERFORM  DIO-FLIP   THRU DIO-EX
001630           MOVE  TEMP-DIO  TO  A-DIO (J).
001640     PERFORM FIND-TYP-PTH  THRU  FIND-TYP-EX.
001650 LOOK-BACK.
001660     IF  END-NO1  IN ARRAY1 (J)  =  BEG-NO1  IN ARRAY1 (K)
001670                 NEXT SENTENCE ELSE
001680             MOVE END-NO1 IN ARRAY1 (K) TO TEMP-HOLD
001690             MOVE TO-C IN ARRAY1 (K) TO TEMP-HOLD1
001700             MOVE BEG-NO1 IN ARRAY1 (K) TO END-NO1 IN ARRAY1 (K)
001710             MOVE FROM-C IN ARRAY1 (K)  TO TO-C IN ARRAY1 (K)
001720             MOVE TEMP-HOLD1  TO  FROM-C IN ARRAY1 (K)
001730             MOVE TEMP-HOLD TO BEG-NO1 IN ARRAY1 (K)
001740             MOVE  K  TO  CK-FLP
001750             MOVE  A-DIO (K)  TO  TEMP-DIO
001760             PERFORM  DIO-FLIP   THRU DIO-EX
001770             MOVE  TEMP-DIO  TO  A-DIO (K).
001780     NOTE -------2------------------------------------------------
001790
001800             THIS PROCEDURE CHECKS ELEMENTS  TO-CONN (J, J = 1)
001810             AGAINST FROM-CONN (K, K = J + 1)
001820
001830             FLIPPING WHEN REQUIRED UNTIL K=I (I = LAST ELEMENT IN
001840             ARRAY FOR THIS PATH)
001850
001860             IN THE FIRST  K=I  TEST -- A CHECK IS MADE FOR A 2
001870             ELEMENT PATH
001880
001890          -------------------------------------------------------.
001900     IF  K  =  I
001910         GO  TO  SKIP-ADDIJ.
001920     ADD  1  TO  J.
001930     ADD  1  TO  K.
001940     IF  K  =  I  NEXT SENTENCE ELSE GO TO LOOK-BACK.
001950 SKIP-ADDIJ.
001960     IF END-NO1 IN ARRAY1 (J)  =  BEG-NO1 IN  ARRAY1 (K)
001970         AND END-NO1 IN ARRAY1 (K)  =  1  OR  =  2
001980         GO  TO  WRT-PROC.
001990     IF  BEG-NO1 (K)  =  1  OR  =  2
002000             NEXT  SENTENCE  ELSE
002010             GO  TO  INCOMPLETE-PATHS.
002020         MOVE END-NO1 IN ARRAY1 (K) TO TEMP-HOLD
002030         MOVE TO-C IN ARRAY1 (K)  TO TEMP-HOLD1
002040         MOVE BEG-NO1 IN ARRAY1 (K) TO END-NO1  IN  ARRAY1 (K)
002050         MOVE FROM-C IN ARRAY1 (K)  TO TO-C IN ARRAY1 (K)
002060         MOVE TEMP-HOLD1  TO  FROM-C  IN  ARRAY1 (K)
002070         MOVE TEMP-HOLD TO BEG-NO1 IN ARRAY1 (K)
002080         MOVE  K  TO  CK-FLP
002090         MOVE  A-DIO (K)  TO  TEMP-DIO
002100         PERFORM  DIO-FLIP   THRU DIO-EX
002110         MOVE  TEMP-DIO  TO  A-DIO (K)
002120                 GO  TO  WRT-PROC.
002130     NOTE -------3------------------------------------------------
002140
002150             THIS PROCEDURE CHECKS AND FLIPS, IF REQUIRED,  THE
002160             LAST ELEMENT    IT ALSO CHECKS FOR INCOMPLETE PATHS
002170             WHERE UPON IT PERFORMS       DUMMY REPORT
002180
002190          -------------------------------------------------------.
002200 INCOMPLETE-PATHS.
002210         ADD  1  TO  NO-BAD-PTHS.
002220         MOVE  1  TO  J.
002230         PERFORM  DUMMY-REPORT  THRU  DUM-EX.
002240         MOVE PATH-HOLD TO  ARRAY1 (1)
002250         MOVE  1  TO  I
002260         MOVE  1  TO     J
002270         MOVE  1  TO     K
002280         GO  TO  RD-1.
002290 WRT-PROC.
002300     MOVE  1  TO  J.
002310 LOOP-1.
002320     PERFORM MV-ARAJ-OUT.
002330     WRITE PATHOUTS     FROM   PATH-OUT-HOLD.
002340     ADD  1  TO  J.
002350     IF  J   >   I   NEXT  SENTENCE  ELSE
002360                 GO  TO  LOOP-1.
002370     PERFORM  EXTRA-PWR-SEG
002380     MOVE  1  TO  I
002390     MOVE  1  TO  J
002400     MOVE  1  TO  K
002410     MOVE  PATH-HOLD TO  ARRAY1 (1).
002420     ADD  1  TO  TOT-PTHS.
002430     GO  TO  RD-1.
002440 EXTRA-PWR-SEG.
002450     ADD  1  TO  E-NO1 (I).
002460     MOVE  END-NO1 (I)  TO  TEMP-HOLD.
002470     MOVE   TO-C (I)  TO  TEMP-HOLD1.
002480     MOVE  BEG-NO1  (I) TO  END-NO1 (I).
002490     MOVE  FROM-C (I)  TO  TO-C (I).
002500     MOVE  TEMP-HOLD  TO  BEG-NO1 (I).
002510     MOVE  TEMP-HOLD1  TO  FROM-C (I).
002520     MOVE   0  TO  BRA-NO1 (I).
002530     COMPUTE  J  =  J  -  1.
002540     PERFORM  MV-ARAJ-OUT.
002550     WRITE  PATHOUTS   FROM   PATH-OUT-HOLD.
002560 EXTRA-PWR-SEG-DON.
002570     EXIT.
002580 DUMMY-REPORT.
002590     PERFORM MV-ARAJ-OUT.
002600     WRITE   PATHOUTS    FROM    PATH-OUT-HOLD.
002610     ADD  1  TO  J.
002620     IF  J  =  I     NEXT  SENTENCE  ELSE
002630                 GO  TO  DUMMY-REPORT.
002640     COMPUTE  J  =  J  -  1.
002650     IF END-NO1 (J) = BEG-NO1 (I)
002660         ADD  1  TO  J
002670         PERFORM MV-ARAJ-OUT
002680         WRITE PATHOUTS FROM PATH-OUT-HOLD
002690         PERFORM EXTRA-SEG  THRU  EXTRA-SEG-DONE
002700         GO  TO  DUM-EX.
002710     ADD  1  TO  J.
002720     MOVE  TO-C (J)  TO  TEMP-HOLD1.
002730     MOVE  END-NO1 (J)  TO  TEMP-HOLD.
002740     MOVE  BEG-NO1 (J)  TO  END-NO1 (J).
002750     MOVE  TEMP-HOLD  TO   BEG-NO1 (J).
002760     MOVE  FROM-C (J)  TO  TO-C (J).
002770     MOVE  TEMP-HOLD1  TO  FROM-C (J).
002780     MOVE  J  TO  CK-FLP.
002790     MOVE  A-DIO (J)  TO  TEMP-DIO.
002800     PERFORM  DIO-FLIP  THRU  DIO-EX.
002810     MOVE  TEMP-DIO  TO  A-DIO (J).
002820     PERFORM  MV-ARAJ-OUT
002830     WRITE  PATHOUTS  FROM  PATH-OUT-HOLD.
002840     PERFORM  EXTRA-SEG  THRU  EXTRA-SEG-DONE.
002850 DUM-EX.
002860     EXIT.
002870 EXTRA-SEG.
002880     MOVE  END-NO1 (I)   TO  BEG-NO1  (I).
002890     MOVE  TO-C (I)  TO  FROM-C  (I).
002900     MOVE   2  TO  END-NO1 (I).
002910     MOVE   0  TO  BRA-NO1 (I).
002920     ADD  1  TO  E-NO1 (I).
002930     MOVE  '  DUMMY GND     '      TO  TO-C (I).
002940     NOTE -------4------------------------------------------------
002950
002960             THE EXTRA SEGMENT IS CREATED BY REVERSING THE LAST
002970             SEGMENT WHICH IS ALWAYS IN THE FORM
002980                 FROM CONNECTOR      TO CONNECTOR
002990                 (ANY ELEMENT)       (PWR / GND / INCOMPLETE PATH)
003000
003010     EXAMPLE     J15-1               PWR
003020     EXTRA SEG   PWR                 J15-1
003030
003040     EXAMPLE     J15-1               J15-2
003050     EXTRA SEG   J15-2               BLANK
003060     (INCOMPLETE DUMMY GND           BLANK
003070      PATH 2 EXT
003080      RA SEGS
003090      GENERATED)
003100
003110          -------------------------------------------------------.
003120     MOVE  '0'   TO  A-DIO (I).
003130     MOVE  SPACES  TO  DATA-A1 (I).
003140     PERFORM  MV-ARAJ-OUT.
003150     WRITE  PATHOUTS   FROM  PATH-OUT-HOLD.
003160     ADD  1  TO  E-NO1 (I).
003170     MOVE   BEG-NO1  (I)  TO  END-NO1  (I).
003180     MOVE  2  TO  BEG-NO1 (I).
003190     MOVE  FROM-C (I)  TO  TO-C (I).
003200     MOVE  '  DUMMY GND     '    TO  FROM-C (I).
003210     PERFORM  MV-ARAJ-OUT.
003220     WRITE  PATHOUTS  FROM  PATH-OUT-HOLD.
003230 EXTRA-SEG-DONE.
003240     EXIT.
003250 DIO-FLIP.
003260     IF  BEG-NO1 (CK-FLP)  =  1  OR  =  2
003270                       GO  TO  DIO-EX.
003280     IF  END-NO1 (CK-FLP)  =  1  OR  =  2
003290                       GO  TO  DIO-EX.
003300     IF  TEMP-DIO  =  '-'
003310             MOVE  '+'  TO  TEMP-DIO   GO  TO  DIO-EX.
003320     IF  TEMP-DIO  =  '+'
003330             MOVE  '-'  TO  TEMP-DIO.
003340 DIO-EX.
003350     EXIT.
003360 MV-ARAJ-OUT.
003370     MOVE    TYPE-PATH       TO      TYP-P-OUT.
003380     MOVE    P-NO1 (J)       TO      P-NO-OUT.
003390     MOVE    E-NO1 (J)       TO      E-NO-OUT.
003400     MOVE    BRA-NO1 (J)     TO      BR-N-OUT.
003410     MOVE    BEG-NO1 (J)     TO      BG-NO-OUT.
003420     MOVE    END-NO1 (J)     TO      EN-N-OUT.
003430     MOVE    A-SWITCH (J)    TO      SWIT-OUT.
003440     MOVE    BOX-A1 (J)      TO      BOX-OUT.
003450     MOVE    FROM-C (J)      TO      FROM-OUT.
003460     MOVE    TO-C (J)        TO      TO-OUT.
003470     MOVE    A-DIO (J)       TO      OUT-DIO.
003480     MOVE    DATA-A1 (J)     TO      DATA-OUT.
003490 FIND-TYP-PTH.
003500     IF  BEG-NO1 (I)  =  1  OR  =  2     GO  TO  COMPLETE-PTH.
003510     NOTE -------5--------------------------------------------
003520
003530             CLASSIFICATION OF PATHS OCCUR  AS,
003540
003550                 POWER  TO  POWER    =   1
003560                 POWER  TO  GROUND   =   2
003570                GROUND  TO  GROUND   =   3
003580                 INCOMPLETE PATHS    =   4
003590
003600          ---------------------------------------------------.
003610     IF  END-NO1 (I)  =  1  OR  =  2     GO  TO  COMPLETE-PTH.
003620         MOVE   4    TO   TYPE-PATH.
003630         GO  TO  FIND-TYP-EX.
003640 COMPLETE-PTH.
003650     IF  BEG-NO1 (I)  =  1      NEXT SENTENCE  ELSE
003660                     MOVE   3 TO  TYPE-PATH
003670                     GO  TO  FIND-TYP-EX.
003680     IF  BEG-NO1 (I)  =  1   OR   END-NO1 (I)  =  1
003690                     MOVE   1 TO  TYPE-PATH
003700                     GO  TO  FIND-TYP-EX.
003710                     MOVE   2 TO  TYPE-PATH.
003720 FIND-TYP-EX.
003730     EXIT.
003740 STOP-ALL.
003750     DISPLAY  '  TOTAL  GOOD  PATHS  ' TOT-PTHS.
003760     DISPLAY  '  TOTAL INCOMPLETE PATHS  ' NO-BAD-PTHS.
003770     CLOSE  PATHIN.
003780     CLOSE  PATHOUT.
003790     STOP RUN.
CBL
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID.         LEGPTRPT.
000030 AUTHOR.             JESSE VAWTER.
000040 DATE-WRITTEN.       JANUARY 29, 1969.
000050 REMARKS.
000060     THIS PROGRAM READS A PATH INTO CORE, DETERMINES IF PATH IS
000070     POWER-TO-POWER, POWER-TO-GROUND, GROUND-TO-GROUND OR
000080     INCOMPLETE, THE PATH IS FORMATTED AND WRITTEN.
000090 ENVIRONMENT DIVISION.
000100 CONFIGURATION SECTION.
000110 SOURCE-COMPUTER.    IBM-360.
000120 OBJECT-COMPUTER.    IBM-360.
000130 INPUT-OUTPUT SECTION.
000140 FILE-CONTROL.
000150     SELECT PRNTOUT   ASSIGN TO UT-S-PRINTIT.
000160     SELECT REC-IN1   ASSIGN TO UT-S-INPT1.
000170     SELECT REC-IN2   ASSIGN TO UT-S-INPT2.
000180     SELECT CARD-IN   ASSIGN TO UT-S-CRD.
000190 DATA DIVISION.
000200 FILE SECTION.
000210 FD  REC-IN1
000220     BLOCK CONTAINS 10 RECORDS
000230     LABEL RECORDS ARE OMITTED
000240     RECORDING MODE IS F
000250     DATA RECORD IS RCD-IN1.
000260 01  RCD-IN1.
000270     02  FILLER      PICTURE X(6).
000280     02  FILLER      PICTURE X(6).
000290     02  FILLER      PICTURE X(66).
000300     02  N1          PICTURE 99V9.
000310     02  N2  REDEFINES N1.
000320         03  FILLER  PICTURE X(3).
000330     02  FILLER      PICTURE X(99).
000340     02  FILLER      PICTURE X.
000350 FD  REC-IN2
000360     BLOCK CONTAINS 10 RECORDS
000370     LABEL RECORDS ARE OMITTED
000380     RECORDING MODE IS F
000390     DATA RECORD IS RCD-IN2.
000400 01  RCD-IN2.
000410     02  FILLER          PICTURE X(6).
000420     02  FILLER          PICTURE X(6).
000430     02  FILLER          PICTURE X(66).
000440     02  N3              PICTURE 99V9.
000450     02  N4  REDEFINES N3.
000460         03  FILLER  PICTURE X(3).
000470     02  FILLER      PICTURE X(99).
000480     02  FILLER      PICTURE X.
000490 FD  PRNTOUT
000500     LABEL RECORDS ARE OMITTED
000510     BLOCK CONTAINS 7 RECORDS
000520     RECORDING MODE IS F
000530     DATA RECORD IS LINER.
000540 01  LINER.
000550     02  FILLER          PICTURE X(132).
000560 FD  CARD-IN
000570     BLOCK CONTAINS 1 RECORDS
000580     RECORDING MODE IS F
000590     LABEL RECORDS ARE OMITTED
000600     DATA RECORD IS CARDD.
000610 01  CARDD.
000620     02  VEH-I           PICTURE X(14).
000630     02  FILLER          PICTURE X(6).
000640     02  DATE-I          PICTURE X(8).
000650     02  FILLER          PICTURE X(2).
000660     02  FILLER          PICTURE X(35).
000670     02  FILLER          PICTURE X(15).
000680 WORKING-STORAGE SECTION.
000690 77  WS-STARTS-HERE      PICTURE X(16)  VALUE 'DATA-STARTS-HERE'.
000700 77  PATH-COUNTER    PICTURE 9(6) VALUE ZERO.
000710 77  LEGAL-PATHS         PICTURE 9999   VALUE ZERO.
000720 77  NON-LEGAL-PATHS     PICTURE 9999   VALUE ZERO.
000730 77  I                   PICTURE 9999    VALUE ZERO.
000740 77  J                   PICTURE 9999    VALUE ZERO.
000750 77  K                   PICTURE 9999    VALUE ZERO.
000760 77  PATH-SAV            PICTURE X(6)    VALUE SPACE.
000770 77  LEGALITY            PICTURE X(3)    VALUE SPACE.
000780 77  LINE-CT             PICTURE 99      VALUE ZERO.
000790 77  PG-CT               PICTURE 999   VALUE ZERO.
000800 77  TAPE-END        PICTURE X(3)  VALUE SPACE.
000810 77  ONE             PICTURE X(6)  VALUE '000001'.
000820 77  TWO             PICTURE X(6)  VALUE '000002'.
000830 77  DUM-GND         PICTURE X(16) VALUE '  DUMMY GND     '.
000840 77  PWR-TO-PWR      PICTURE X(37)
000850         VALUE  ' POWER-TO-POWER THRU SWITCH AND NODE '.
000860 77  PWR-TO-GND      PICTURE X(37)
000870         VALUE  ' POWER-TO-GROUND THRU SWITCH AND NODE'.
000880 77  GND-TO-GND      PICTURE X(37)
000890         VALUE  'GROUND-TO-GROUND THRU SWITCH AND NODE'.
000900 77  INCOMP          PICTURE X(37)
000910         VALUE  ' INCOMPLETE PATH THRU SWITCH AND NODE'.
000920 77  IMP-O               PICTURE ZZ.9.
000930 01  ARRAY-PATH.
000940     02  REC OCCURS 500 TIMES.
000950         03  FILLER      PICTURE X(12).
000960         03  FILLER  PICTURE X(6).
000970         03  FROM-NO     PICTURE X(6).
000980         03  FILLER  PICTURE X(6).
000990         03  FILLER      PICTURE X(15).
001000         03  CHECKER     PICTURE X(16).
001010         03  FILLER      PICTURE X(17).
001020         03  FILLER      PICTURE 99V9.
001030         03  FILLER      PICTURE X(98).
001040         03  FILLER  PICTURE X.
001050         03  LEG-PTH     PICTURE X.
001060 01  RCD-I.
001070     02  PATHI           PICTURE X(6).
001080     02  FILLER          PICTURE X(12).
001090     02  FILLER      PICTURE X(6).
001100     02  FILLER      PICTURE X(6).
001110     02  DATA-IN.
001120         03  FILLER      PICTURE X(48).
001130         03  IMP1        PICTURE 99V9.
001140         03  IMP2 REDEFINES IMP1.
001150             04  FILLER  PICTURE X(3).
001160         03  FILLER      PICTURE X(99).
001170     02  FILLER      PICTURE X.
001180 01  WORK-REC.
001190         03  FILLER          PICTURE X(6).
001200         03  FILLER          PICTURE X(6).
001210         03  FILLER  PICTURE X(6).
001220         03  F-NO            PICTURE X(6).
001230         03  FILLER  PICTURE X(6).
001240         03  BID-DATA.
001250             04  BOX-URD     PICTURE X(15).
001260             04  DUM-GND-CK.
001270              05 FILLER      PICTURE X(2).
001280              05 WTI         PICTURE X(6).
001290              05 F-BAY       PICTURE X(3).
001300              05 FILLER      PICTURE X.
001310              05 PENX        PICTURE X(4).
001320             04  FILLER      PICTURE X(16).
001330             04  DIOD-I      PICTURE X.
001340             04  IMP-I       PICTURE 99V9.
001350             04  IMP2-I REDEFINES IMP-I.
001360                 05  FILLER  PICTURE X(3).
001370             04  UNIT-DWG-NO PICTURE X(21).
001380             04  FILLER      PICTURE X(39).
001390             04  REMARKS1    PICTURE X(38).
001400         03  BED-DATA REDEFINES BID-DATA.
001410             04  FILLER      PICTURE X(51).
001420             04  A-HARN      PICTURE X(7).
001430             04  FILLER      PICTURE X(8).
001440             04  REMARKS2    PICTURE X(38).
001450             04  FILLER      PICTURE X(45).
001460         03  FILLER          PICTURE X.
001470         03  FILLER  PICTURE X.
001480 01  REC-O.
001490     02  FILLER      PICTURE X(4)    VALUE SPACE.
001500     02  BAY-O           PICTURE X(3).
001510     02  FILLER          PICTURE XX  VALUE SPACE.
001520     02  DUM-WIRE-TERM.
001530      03 WIRE-TERM       PICTURE X(6).
001540      03 FILLER          PICTURE X(6)   VALUE SPACES.
001550      03 PINX            PICTURE X(4).
001560     02  FILLER      PICTURE X(4)    VALUE SPACE.
001570     02  AREA-HARN       PICTURE X(7).
001580     02  FILLER      PICTURE X(3)    VALUE SPACE.
001590     02  UNIT-REF-DES    PICTURE X(15).
001600     02  FILLER      PICTURE X(3)    VALUE SPACE.
001610     02  UNIT-DRAW       PICTURE X(21).
001620     02  FILLER      PICTURE X(3)    VALUE SPACE.
001630     02  DIOD-O          PICTURE X.
001640     02  FILLER          PICTURE X(3)    VALUE SPACE.
001650     02  IMP-OUT         PICTURE X(4).
001660     02  FILLER          PICTURE X(3)    VALUE SPACE.
001670     02  REMARKS3.
001680         03  FILLER    PICTURE X(37).
001690         03  REMK2     PICTURE X(01).
001700     02  FILLER          PICTURE X(2)    VALUE SPACE.
001710 01  LINE1.
001720     02  FILLER      PICTURE X(32)   VALUE SPACE.
001730     02  VEH-O           PICTURE X(16) VALUE SPACE.
001740     02  FILLER      PICTURE X(36)
001750             VALUE  'PATH REPORT, AUTOMATED SNEAK PROGRAM'.
001760     02  FILLER      PICTURE X(7)
001770              VALUE '  DATE '.
001780     02  DATE-O          PICTURE X(8) VALUE SPACE.
001790     02  FILLER          PICTURE X(6) VALUE ' PAGE '.
001800     02  PAG         PICTURE ZZ9.
001810     02  FILLER      PICTURE X(9)    VALUE  ' OF PATH '.
001820     02  PAT         PICTURE X(6).
001830     02  FILLER      PICTURE X(09)   VALUE  '.        '.
001840 01  LINE2.
001850     02  FILLER      PICTURE X(48)   VALUE SPACE.
001860     02  TYP-REPT    PICTURE X(37)
001870      VALUE '    PATH THROUGH SWITCH AND NODE   '.
001880     02  FILLER      PICTURE X(47)   VALUE SPACE.
001890 01  LINE3.
001900     02  FILLER      PICTURE X(7)    VALUE SPACE.
001910     02  FILLER      PICTURE X(4)    VALUE  'WIRE'.
001920     02  FILLER      PICTURE X(28)   VALUE SPACE.
001930     02  FILLER      PICTURE X(4)    VALUE  'BOX '.
001940     02  FILLER      PICTURE X(14)   VALUE SPACE.
001950     02  FILLER      PICTURE X(4)    VALUE  'BOX '.
001960     02  FILLER          PICTURE X(20) VALUE SPACE.
001970     02  FILLER          PICTURE X     VALUE 'D'.
001980     02  FILLER          PICTURE X(50) VALUE SPACE.
001990 01  LINE4.
002000     02  FILLER      PICTURE X(4)    VALUE SPACE.
002010     02  FILLER      PICTURE X(45)  VALUE
002020          'TERMINATION        PIN    AREA     REFERENCE '.
002030     02  FILLER      PICTURE X(8)    VALUE SPACE.
002040     02  FILLER      PICTURE X(7)    VALUE  'DRAWING'.
002050     02  FILLER          PICTURE X(17) VALUE SPACE.
002060     02  FILLER          PICTURE X(8)  VALUE 'I    IMP'.
002070     02  FILLER          PICTURE X(19) VALUE SPACE.
002080     02  FILLER      PICTURE X(7)    VALUE  'REMARKS'.
002090     02  FILLER      PICTURE X(17)   VALUE SPACE.
002100 01  LINE5.
002110     02  FILLER      PICTURE X(4)    VALUE SPACE.
002120     02  FILLER      PICTURE X(11)   VALUE  'BAY    ITEM'.
002130     02  FILLER      PICTURE X(14)   VALUE SPACE.
002140     02  FILLER      PICTURE X(34)
002150         VALUE  'HARNESS   DESIGNATOR        NUMBER'.
002160     02  FILLER          PICTURE X(18)   VALUE SPACE.
002170     02  FILLER          PICTURE X       VALUE 'O'.
002180     02  FILLER          PICTURE X(50)   VALUE SPACE.
002190 01  LINE6.
002200     02  FILLER      PICTURE X(9)    VALUE SPACE.
002210     02  FILLER      PICTURE X(8)    VALUE  'ANALYST '.
002220     02  FILLER      PICTURE X(30)   VALUE IS ALL '.'.
002230     02  FILLER      PICTURE X(10)   VALUE SPACE.
002240     02  FILLER      PICTURE X(5)    VALUE  'DATE '.
002250     02  FILLER      PICTURE X(15)   VALUE IS ALL '.'.
002260     02  FILLER      PICTURE X(10)   VALUE SPACE.
002270     02  FILLER      PICTURE X(9)    VALUE  'MANHOURS '.
002280     02  FILLER      PICTURE X(25)   VALUE IS ALL '.'.
002290     02  FILLER      PICTURE X(11)   VALUE SPACE.
002300 01  LINE7.
002310     02  FILLER      PICTURE X(9)    VALUE SPACE.
002320     02  FILLER      PICTURE X(17)   VALUE  'CONTINUITY VALID '.
002330     02  FILLER      PICTURE X(15)   VALUE IS ALL '.'.
002340     02  FILLER      PICTURE X(7)    VALUE  '(YES)  '.
002350     02  FILLER      PICTURE X(15)   VALUE IS ALL '.'.
002360     02  FILLER      PICTURE X(4)    VALUE  '(NO)'.
002370     02  FILLER      PICTURE X(4)    VALUE SPACE.
002380     02  FILLER     PICTURE X(16)  VALUE 'SNEAK GENERATED '.
002390     02  FILLER      PICTURE X(15)   VALUE IS ALL '.'.
002400     02  FILLER      PICTURE X(7)    VALUE  '(YES)  '.
002410     02  FILLER      PICTURE X(15)   VALUE IS ALL '.'.
002420     02  FILLER      PICTURE X(4)    VALUE  '(NO)'.
002430     02  FILLER      PICTURE X(4)    VALUE SPACE.
002440 01  LINE8.
002450         02  FILLER  PICTURE X(9)    VALUE SPACE.
002460         02  FILLER  PICTURE X(8)    VALUE  'COMMENTS'.
002470         02  FILLER  PICTURE X(115)  VALUE SPACE.
002480 01  ASTR.
002490     02  FILLER      PICTURE X(4)    VALUE SPACE.
002500     02  FILLER      PICTURE X(66)   VALUE IS ALL '*'.
002510     02  FILLER      PICTURE X(52)   VALUE IS ALL '*'.
002520     02  FILLER      PICTURE X(10)   VALUE SPACE.
002530 01  BLANK-LINE.
002540     02  FILLER      PICTURE X(132)  VALUE SPACE.
002550 PROCEDURE DIVISION.
002560     OPEN INPUT REC-IN1.
002570     OPEN    OUTPUT  REC-IN2.
002580     OPEN INPUT  CARD-IN.
002590     OPEN OUTPUT PRNTOUT.
002600     ADD 1 TO PATH-COUNTER.
002610     PERFORM WRITE-FOOTER.
002620     READ CARD-IN AT END  DISPLAY 'NO DATE CARD ' GO TO THE-END.
002630     MOVE VEH-I TO VEH-O.
002640     MOVE DATE-I TO DATE-O.
002650     READ REC-IN1 INTO RCD-I AT END DISPLAY 'NO DATA '
002660                         GO TO THE-END.
002670 BUILD-ARRAY.
002680     ADD 1 TO I.
002690     MOVE RCD-I TO REC (I).
002700     MOVE PATHI TO PATH-SAV.
002710 READ-IT.
002720     IF TAPE-END = 'YES'
002730         READ REC-IN2 INTO RCD-I AT END
002740                      ALTER GO-BACK TO PROCEED TO THE-END
002750                      GO TO WRITE-ARRAY
002760        ELSE
002770         READ REC-IN1 INTO RCD-I AT END
002780                      MOVE 'YES' TO TAPE-END
002790                      GO TO READ-IT.
002800     IF PATHI = PATH-SAV GO TO BUILD-ARRAY.
002810     ADD 1 TO PATH-COUNTER.
002820 WRITE-ARRAY.
002830     PERFORM TYPE-PATH THRU TPE.
002840     MOVE 1 TO J.
002850     MOVE PATH-SAV TO PAT.
002860     MOVE ZERO TO PG-CT  PERFORM WRITE-HEADER.
002870 MOVE-DATA-J.
002880     MOVE SPACE TO WORK-REC.
002890     MOVE REC (J) TO WORK-REC.
002900     IF F-NO = '000002' AND DUM-GND-CK = DUM-GND
002910         MOVE SPACE TO REC-O
002920         MOVE DUM-GND TO DUM-WIRE-TERM
002930         GO TO WRITE-IT.
002940     IF F-NO     = '000002' MOVE 'GND       ' TO WTI.
002950     IF WTI     = SPACE MOVE 'PWR       ' TO WTI.
002960     MOVE WTI     TO WIRE-TERM.
002970     MOVE F-BAY TO BAY-O.
002980     MOVE PENX     TO PINX.
002990     IF DIOD-I     = SPACE MOVE '0' TO DIOD-O
003000                   ELSE MOVE DIOD-I     TO DIOD-O.
003010     IF IMP2-I     = SPACE MOVE ZERO TO IMP-O
003020                   MOVE IMP-O TO IMP-OUT
003030                   ELSE MOVE IMP-I     TO IMP-O
003040                   MOVE IMP-O TO IMP-OUT.
003050     IF BOX-URD     = SPACES
003060                   MOVE SPACE TO UNIT-REF-DES
003070                   MOVE SPACE TO UNIT-DRAW
003080                   MOVE A-HARN     TO AREA-HARN
003090                   MOVE REMARKS2     TO REMARKS3
003100             ELSE
003110                   MOVE UNIT-DWG-NO     TO UNIT-DRAW
003120                   MOVE SPACES  TO AREA-HARN
003130                   MOVE BOX-URD     TO UNIT-REF-DES
003140                   MOVE REMARKS1     TO REMARKS3.
003150     IF REMK2 = '*' MOVE SPACE TO REMK2.
003160 WRITE-IT.
003170     IF LINE-CT < 40 NEXT SENTENCE
003180         ELSE PERFORM WRITE-HEADER.
003190     IF I = J MOVE SPACES TO REMARKS3 IMP-OUT DIOD-O.
003200     WRITE LINER FROM REC-O AFTER POSITIONING 1.
003210     MOVE SPACE TO DUM-WIRE-TERM.
003220     ADD 1 TO LINE-CT.
003230     ADD 1 TO J.
003240     IF J > I  PERFORM WRITE-FOOTER
003250               MOVE ZERO TO I
003260         ELSE GO TO MOVE-DATA-J.
003270 GO-BACK.
003280     GO TO BUILD-ARRAY.
003290 TYPE-PATH.
003300     IF FROM-NO (1) = ONE AND FROM-NO (I) = ONE
003310     MOVE PWR-TO-PWR TO TYP-REPT GO TO TPE.
003320     IF FROM-NO (1) = ONE AND FROM-NO (I) = TWO
003330         AND CHECKER (I) NOT = DUM-GND
003340     MOVE PWR-TO-GND TO TYP-REPT GO TO TPE.
003350     IF FROM-NO (1) = TWO AND FROM-NO (I) = TWO
003360         AND CHECKER (I) NOT = DUM-GND
003370     MOVE GND-TO-GND TO TYP-REPT GO TO TPE.
003380     MOVE INCOMP TO TYP-REPT.
003390 TPE.
003400     EXIT.
003410 IS-IT-LEGAL.
003420     MOVE 1 TO K.
003430 IIL-1.
003440     IF LEG-PTH (K) = 'S'
003450                 MOVE 'YES' TO LEGALITY
003460                 ADD 1 TO LEGAL-PATHS
003470                 GO TO IIL-END.
003480     ADD 1 TO K.
003490     IF K > I MOVE ' NO' TO LEGALITY
003500                 ADD 1 TO NON-LEGAL-PATHS
003510               GO TO IIL-END.
003520     GO TO IIL-1.
003530 IIL-END.
003540     EXIT.
003550 WRITE-HEADER.
003560     ADD 1 TO PG-CT.
003570     MOVE  PG-CT TO PAG.
003580     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 0.
003590     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 3.
003600     WRITE LINER FROM LINE1      AFTER POSITIONING 3.
003610     WRITE LINER FROM LINE2      AFTER POSITIONING 3.
003620     WRITE LINER FROM ASTR       AFTER POSITIONING 1.
003630     WRITE LINER FROM LINE3      AFTER POSITIONING 1.
003640     WRITE LINER FROM LINE4      AFTER POSITIONING 1.
003650     WRITE LINER FROM LINE5      AFTER POSITIONING 1.
003660     WRITE LINER FROM ASTR       AFTER POSITIONING 1.
003670     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 1.
003680     MOVE 1 TO LINE-CT.
003690 WRITE-FOOTER.
003700     WRITE LINER FROM ASTR       AFTER POSITIONING 2.
003710     WRITE LINER FROM BLANK-LINE AFTER POSITIONING 3.
003720     WRITE LINER FROM LINE6      AFTER POSITIONING 1.
003730     WRITE LINER FROM LINE7      AFTER POSITIONING 3.
003740     WRITE LINER FROM LINE8      AFTER POSITIONING 2.
003750 THE-END.
003760     CLOSE REC-IN1.
003770     CLOSE REC-IN2.
003780     CLOSE CARD-IN.
003790     CLOSE PRNTOUT.
003800     DISPLAY 'THATS ALL FOLKS'.
003810     DISPLAY 'TOTAL PATHS     ' PATH-COUNTER.
003820     DISPLAY  'LEGAL PATHS     ' LEGAL-PATHS.
003830     DISPLAY  'NON-LEGAL-PATHS ' NON-LEGAL-PATHS.
003840     STOP RUN.
